diff --git a/README.md b/README.md
index 41af8172..279f2b72 100755
--- a/README.md
+++ b/README.md
@@ -33,9 +33,12 @@ conventional Unix-style syntax for short and long parameters:
! Define command and default values and parse supplied command line options
call set_args('-x 1 -y 2.0 -z 3.5e0 -p 11,-22,33 --title:T "my title" -l F -L F')
!
- ! Get scalar non-allocatable values
+ ! multiple scalar non-allocatable values can be done in one call if desired
call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
- ! use convenience functions for allocatable arrays and strings
+
+ ! you can use convenience functions for allocatable arrays and strings.
+ ! The functions are particularly useful in expressions and as arguments on
+ ! procedure calls
title=sget('title') ! string
p=igets('p') ! integer array
!
diff --git a/docs/BOOK_M_CLI2.html b/docs/BOOK_M_CLI2.html
index 3ec5cc26..5ca103de 100755
--- a/docs/BOOK_M_CLI2.html
+++ b/docs/BOOK_M_CLI2.html
@@ -59,6 +59,10 @@
border-color: blue;
}
/* ======================================================== */
+summary{
+ background-color: white;
+}
+/* ======================================================== */
body{
background-color: black;
margin-top: 1.58em;
diff --git a/docs/M_CLI2.3m_cli2.html b/docs/M_CLI2.3m_cli2.html
index 88e319e1..6f013cd7 100755
--- a/docs/M_CLI2.3m_cli2.html
+++ b/docs/M_CLI2.3m_cli2.html
@@ -163,8 +163,8 @@
EXAMPLE
implicit none
integer :: i
integer,parameter :: dp=kind(0.0d0)
- !
- ! DEFINE ARGS
+ !
+ ! Define ARGS
real :: x, y, z
logical :: l, lbig
character(len=40) :: label ! FIXED LENGTH
@@ -173,15 +173,15 @@
EXAMPLE
character(len=:),allocatable :: title ! VARIABLE LENGTH
real :: p(3) ! FIXED SIZE
logical :: logi(3) ! FIXED SIZE
- !
- ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
- ! o set a value for all keywords.
- ! o double-quote strings, strings must be at least one space
- ! because adjacent double-quotes designate a double-quote
- ! in the value.
- ! o set all logical values to F
- ! o numeric values support an "e" or "E" exponent
- ! o for lists delimit with a comma, colon, or space
+ !
+ ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+ ! o set a value for all keywords.
+ ! o double-quote strings, strings must be at least one space
+ ! because adjacent double-quotes designate a double-quote
+ ! in the value.
+ ! o set all logical values to F
+ ! o numeric values support an "e" or "E" exponent
+ ! o for lists delimit with a comma, colon, or space
call set_args(’ &
& -x 1 -y 2 -z 3 &
& -p -1 -2 -3 &
@@ -192,25 +192,34 @@
EXAMPLE
& --label " " &
! note space between quotes is required
& ’)
- ! ASSIGN VALUES TO ELEMENTS
- ! non-allocatable scalars can be done up to twenty per call
+ ! Assign values to elements using G_ARGS(3f).
+ ! non-allocatable scalars can be done up to twenty per call
call get_args(’x’,x, ’y’,y, ’z’,z, ’l’,l, ’L’,lbig)
- !
- ! allocatables should be done one at a time
+ ! As a convenience multiple pairs of keywords and variables may be
+ ! specified if and only if all the values are scalars and the CHARACTER
+ ! variables are fixed-length or pre-allocated.
+ !
+ ! After SET_ARGS(3f) has parsed the command line
+ ! GET_ARGS(3f) retrieves the value of keywords accept for
+ ! two special cases. For fixed-length CHARACTER variables
+ ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+ ! GET_ARGS_FIXED_SIZE(3f).
+ !
+ ! allocatables should be done one at a time
call get_args(’title’,title) ! allocatable string
call get_args(’point’,point) ! allocatable arrays
call get_args(’logicals’,logicals)
- !
- ! less commonly ...
+ !
+ ! less commonly ...
- ! for fixed-length strings
+ ! for fixed-length strings
call get_args_fixed_length(’label’,label)
- ! for non-allocatable arrays
+ ! for non-allocatable arrays
call get_args_fixed_size(’p’,p)
call get_args_fixed_size(’logi’,logi)
- !
- ! all done parsing, use values
+ !
+ ! all done parsing, use values
write(*,*)’x=’,x, ’y=’,y, ’z=’,z, x+y+z
write(*,*)’p=’,p
write(*,*)’point=’,point
@@ -220,13 +229,13 @@
Note that the convenience routines are described under get_args(3f):
dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),
igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f)
-
M_CLI2 - parse Unix-like command line arguments from Fortran
Description
M_CLI2(3f) is a Fortran module that will crack the command line when
given a prototype string that looks very much like an invocation of
- the program. A call to get_args(3f) or one of its variants is then
- made for each parameter name to set the variables appropriately in
- the program.
+ the program. calls are then made for each parameter name to set the
+ variables appropriately in the program.
Example Program
-
This short program defines a command that can be called like
-
./show -x 10 -y -20 -p 10,20,30 --title 'plot of stuff' -L
- # these parameters are defined automatically
- ./show --usage
- ./show --help
- ./show --version
- # you must supply text for "help" and "version" if desired.
+
This short program defines a command that can be called using
+conventional Unix-style syntax for short and long parameters:
+
./show -x 10 -y -20 -p 10,20,30 --title "plot of stuff" -L
+ ./show -lL
+ ./show --title="my new title"
+ ./show -T "my new title"
program show
-use M_CLI2,only:set_args,lget,rget,sget,igets
+use M_CLI2,only:set_args,get_args,sget,igets,set_modeimplicit none
-real::sum
-integer,allocatable::p(:)
-character(len=:),allocatable::title
+real::x,y,zlogical::l,lbig
+integer,allocatable::p(:)
+character(len=:),allocatable::title
+namelist/args/x,y,z,l,lbig,p,title! just for printing
+call set_mode('strict')!! Define command and default values and parse supplied command line options
+call set_args('-x 1 -y 2.0 -z 3.5e0 -p 11,-22,33 --title:T "my title" -l F -L F')!
-call set_args('-x 1 -y 2.0 -z 3.5e0 -p 11,-22,33 --title "my title" -l F -L F')
-!
-! Get values using convenience functions
-!
-sum=rget('x')+rget('y')+rget('z')
-title=sget('title')
-p=igets('p')
-l=lget('l')
-lbig=lget('L')
-!
-! All ready to go
+! multiple scalar non-allocatable values can be done in one call if desired
+call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+
+! you can use convenience functions for allocatable arrays and strings.
+! The functions are particularly useful in expressions and as arguments on
+! procedure calls
+title=sget('title')! string
+p=igets('p')! integer array!
-write(*,*)sum,l,lbig,p,title
+! All ready to go, print it as a namelist so everything is labeled
+write(*,args)end program show
An arbitrary number of strings such as filenames may be passed in on
-the end of commands, you can query whether an option was supplied, and
+the end of commands; you can query whether an option was supplied; and
get_args(3f)-related routines can be used for refining options such as
-requiring lists of a specified size. Passing in some character arrays
-allows you to automatically have a –help and –version switch as well,
-as explained using the examples below.
-
Demo Programs
-
These demo programs provide templates for the most common usage:
+requiring lists of a specified size.
+
These parameters are defined automatically
+
--help
+ --usage
+ --version
+
+
+
You must supply text for the optional “–help” and “–version” keywords, as
+described under SET_ARGS(3f).
demo8 Parsing multiple keywords in a single call to get_args(3f) for limited cases
-
demo9 Long and short names using –LONGNAME:SHORTNAME. When all keys have
- a long and short name “strict mode” is invoked where “–” is required
- for long names and “-” for short names; and Boolean values may be
- bundled together.
Compile the M_CLI2 module and build all the example programs.
-
git clone https://github.com/urbanjost/M_CLI2.git
- cd M_CLI2/src
- # change Makefile if not using one of the listed compilers
+
git clone https://github.com/urbanjost/M_CLI2.git
+ cd M_CLI2/src
+ # change Makefile if not using one of the listed compilers
- # for gfortran
- make clean
- make gfortran
+ # for gfortran
+ make clean
+ make gfortran
- # for ifort
- make clean
- make ifort
+ # for ifort
+ make clean
+ make ifort
- # for nvfortran
- make clean
- make nvfortran
+ # for nvfortran
+ make clean
+ make nvfortran
- # display other options (test, run, doxygen, ford, ...)
- make help
+ # display other options (test, run, doxygen, ford, ...)
+ make help
To install you then generally copy the .mod file and .a file to
@@ -208,6 +220,7 @@
Download and Build with Make(1)Creating a shared library
If you desire a shared library as well, for gfortran you may enter
make clean gfortran gfortran_install
@@ -217,22 +230,25 @@
Download and Build with Make(1)
make clean ifort ifort_install # same for ifort
-
NOTE: These instructions are specific to a ULS (Unix-Like System) and
- may differ, especially for those wishing to generate shared libraries
- which varies significantly from compiler to compiler. For some builds
- it is simpler to make a Makefile for each compiler, which might be
- required for a more comprehensive build unless you are very familiar
- with gmake(1).
+
does the same for the ifort compiler and places the output in libifort/.
+
Specifics may vary
+
NOTE: The build instructions above are specific to a ULS (Unix-Like
+ System) and may differ, especially for those wishing to generate shared
+ libraries (which varies significantly depending on the programming
+ environment). For some builds it is simpler to make a Makefile for
+ each compiler, which might be required for a more comprehensive build
+ unless you are very familiar with gmake(1).
If you always use one compiler it is relatively simple, otherwise
make sure you know what your system requires and change the Makefile
as appropriate.
-
Supports FPM
+
+
Build with FPM
Alternatively, fpm(1) users may download the github repository and build it with
fpm ( as described at Fortran Package Manager )
git clone https://github.com/urbanjost/M_CLI2.git
cd M_CLI2
fpm test# build and test the module
- fpm install # install the module (in the default location)
+ fpm install # install the module (in the default location)
or just list it as a dependency in your fpm.toml project file.
@@ -247,7 +263,12 @@
Supports Meson
cd M_CLI2
meson setup _build
meson test -C _build # build and test the module
- meson install -C _build --destdir <DIR> # install the module (in the <DIR> location)
+
+ # install the module (in the <DIR> location)
+ # --destdir is only on newer versions of meson
+ meson install -C _build --destdir <DIR>
+ # older method if --destdir is not available
+ env DESTDIR=<DIR> meson install -C _build
you add calls to the get_args(3f) procedure or one of its variants (
- The alternatives allow you to use a simple function-based interface
- model. There are special routines for when you want to use fixed length.
- CHARACTER variables or fixed-size arrays instead of the allocatable
- variables best used with get_args(3f)).
+
you add calls to the get_args(3f) procedure or one of its variants.
+ The alternative convenience procedures (rget(3f),sget(3f),iget(3f)
+ …) allow you to use a simple function-based interface model. There
+ are special routines for when you want to use fixed length. CHARACTER
+ variables or fixed-size arrays instead of the allocatable variables
+ best used with get_args(3f)).
Now when you call the program all the values in the prototype should
be updated using values from the command line and queried and ready
to use in your program.
+
+
Demo Programs
+
These demo programs provide templates for the most common usage:
demo5 extended description of using CHARACTER type values
+
Response files
Response files are supported as described in the documentation for
set_args.
@@ -280,44 +328,6 @@
Response files
complex commands. This option is generally not needed by programs with
just a few options, but can be particularly useful for programs with
dozens of options where various values are frequently reused.
-
Documentation
-
man-pages as HTML
-
-
man-pages – man-pages index of individual procedures
-
BOOK_M_CLI2 – All man-pages consolidated using JavaScript
commit 598e44164eee383b8a0775aa75b7d1bb100481c3 was tested on 2020-11-22 with
+ GNU Fortran (GCC) 8.3.1 20191121 (Red Hat 8.3.1-5)
@@ -326,12 +336,16 @@
Commit Tests
commit 8fe841d8c0c1867f88847e24009a76a98484b31a was tested on 2021-09-29 with
+ GNU Fortran (Ubuntu 10.3.0-1ubuntu1~20.04) 10.3.0
+ ifort (IFORT) 2021.3.0 20210609
- + nvfortran 21.5-0 LLVM 64-bit target on x86-64 Linux -tp nehalem
+ + nvfortran 21.5-0 LLVM 64-bit target on x86-64 Linux -tp nehalem
+
commit 732bcadf95e753ccdf025cec2c08d776ea2534c2 was tested on 2023-02-10 with
+ + ifort (IFORT) 2021.8.0 20221119
+ + GNU Fortran (Ubuntu 11.1.0-1ubuntu1~20.04) 11.1.0
-
Last update: Sat 21 Jan 2023 11:10:53 PM EST
+
Last update: Saturday, February 4th, 2023 1:12:54 AM UTC-05:00
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/lists/programs.html b/docs/fpm-ford/lists/programs.html
index 861da278..9888dbb6 100644
--- a/docs/fpm-ford/lists/programs.html
+++ b/docs/fpm-ford/lists/programs.html
@@ -89,16 +89,21 @@
Programs
SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES
ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
USE THE VALUES IN YOUR PROGRAM.
-
@(#) unnamed to numbers
+The default for inums, rnums, … is to convert all unnamed argument values in “unnamed”
@@ -132,7 +146,7 @@
Programs
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/lists/types.html b/docs/fpm-ford/lists/types.html
index 556685e0..c0ab438f 100644
--- a/docs/fpm-ford/lists/types.html
+++ b/docs/fpm-ford/lists/types.html
@@ -102,7 +102,7 @@
Derived Types
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/media/M_CLI2.gif b/docs/fpm-ford/media/M_CLI2.gif
index f8e7c72c..af5a5332 100644
Binary files a/docs/fpm-ford/media/M_CLI2.gif and b/docs/fpm-ford/media/M_CLI2.gif differ
diff --git a/docs/fpm-ford/module/m_cli2.html b/docs/fpm-ford/module/m_cli2.html
index 7908c181..2f46e893 100644
--- a/docs/fpm-ford/module/m_cli2.html
+++ b/docs/fpm-ford/module/m_cli2.html
@@ -90,7 +90,7 @@
M_CLI2
3079 statements
+ title="100.0% of total for modules and submodules.">2637 statements
@@ -219,37 +219,51 @@
NAME
SYNOPSIS
Available procedures and variables:
-
use M_CLI2, only : set_args, get_args, specified, set_mode
- use M_CLI2, only : unnamed, remaining, args
- use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
- ! convenience functions
- use M_CLI2, only : dget, iget, lget, rget, sget, cget
- use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
+
Note that the convenience routines are described under get_args(3f):
+ dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),
+ igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f)
47 statements
+ title="12.3% of total for procedures.">47 statements
@@ -190,8 +190,8 @@
EXAMPLE
!x! You can call this program which has two subcommands (run, test),!x! like this:!x! demo_get_subcommand --help
-!x! demo_get_subcommand run -x -y -z -title -l -L
-!x! demo_get_subcommand test -title -l -L -testname
+!x! demo_get_subcommand run -x -y -z --title -l -L
+!x! demo_get_subcommand test --title -l -L --testname!x! demo_get_subcommand run --helpimplicitnone!x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
@@ -228,8 +228,8 @@
EXAMPLE
!generalhelpfor"demo_get_subcommand --help"help_text=[character(len=80)::&' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
+' * run -l -L --title -x -y -z ',&
+' * test -l -L --title ',&'']!findthesubcommandnamebylookingforfirstwordoncommand!notstartingwithdash
@@ -343,7 +343,7 @@
Contents
Source Code
function get_subcommand()result(sub)
-! ident_3="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"
+! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"character(len=:),allocatable::subcharacter(len=:),allocatable::cmdarg
@@ -416,7 +416,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
5 statements
+ title=" 1.3% of total for procedures.">5 statements
@@ -257,7 +257,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/proc/my_run.html b/docs/fpm-ford/proc/my_run.html
index cd60922a..925ab6fb 100644
--- a/docs/fpm-ford/proc/my_run.html
+++ b/docs/fpm-ford/proc/my_run.html
@@ -90,7 +90,7 @@
my_run
10 statements
+ title=" 2.6% of total for procedures.">10 statements
@@ -168,7 +168,7 @@
Arguments
-
+
real,
intent(in)
@@ -183,7 +183,7 @@
Arguments
-
+
real,
intent(in)
@@ -198,7 +198,7 @@
Arguments
-
+
real,
intent(in)
@@ -335,7 +335,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/proc/parse.html b/docs/fpm-ford/proc/parse.html
index ecc17c7a..ce1ef41f 100644
--- a/docs/fpm-ford/proc/parse.html
+++ b/docs/fpm-ford/proc/parse.html
@@ -90,7 +90,7 @@
parse
16 statements
+ title=" 4.2% of total for procedures.">16 statements
@@ -320,58 +320,58 @@
Variables
Source Code
-
subroutine parse()
-!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
-use M_CLI2,only:set_args,get_args
-use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
-character(len=:),allocatable::help_text(:),version_text(:)
-
-!! DEFINE COMMAND PROTOTYPE
-!! o All parameters must be listed with a default value
-!! o string values must be double-quoted
-!! o numeric lists must be comma-delimited. No spaces are allowed
-!! o long keynames must be all lowercase
-
-character(len=*),parameter::cmd='&
+
subroutine parse()
+!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
+use M_CLI2,only:set_args,get_args
+use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
+character(len=:),allocatable::help_text(:),version_text(:)
+
+!! DEFINE COMMAND PROTOTYPE
+!! o All parameters must be listed with a default value
+!! o string values must be double-quoted
+!! o numeric lists must be comma-delimited. No spaces are allowed
+!! o long keynames must be all lowercase
+
+character(len=*),parameter::cmd='& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title "my title" & & -l F -L F & & '
-help_text=[character(len=80)::&
-'NAME ',&
-' myprocedure(1) - make all things possible ',&
-'SYNOPSIS ',&
-' function myprocedure(stuff) ',&
-' class(*) :: stuff ',&
-'DESCRIPTION ',&
-' myprocedure(1) makes all things possible given STUFF ',&
-'OPTIONS ',&
-' STUFF things to do things to ',&
-'RETURNS ',&
-' MYPROCEDURE the answers you want ',&
-'EXAMPLE ',&
-'']
-
-version_text=[character(len=80)::&
-'@(#)PROGRAM: demo2 >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200115 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-'']
-
-call set_args(cmd,help_text,version_text)
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-call get_args_fixed_size('point',point)
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-
-end subroutine parse
+help_text=[character(len=80)::&
+'NAME ',&
+' myprocedure(1) - make all things possible ',&
+'SYNOPSIS ',&
+' function myprocedure(stuff) ',&
+' class(*) :: stuff ',&
+'DESCRIPTION ',&
+' myprocedure(1) makes all things possible given STUFF ',&
+'OPTIONS ',&
+' STUFF things to do things to ',&
+'RETURNS ',&
+' MYPROCEDURE the answers you want ',&
+'EXAMPLE ',&
+'']
+
+version_text=[character(len=80)::&
+'@(#)PROGRAM: demo2 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200115 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+'']
+
+call set_args(cmd,help_text,version_text)
+call get_args('x',x)
+call get_args('y',y)
+call get_args('z',z)
+call get_args_fixed_size('point',point)
+call get_args_fixed_length('title',title)
+call get_args('l',l)
+call get_args('L',l_)
+
+end subroutine parse
@@ -392,7 +392,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
subroutine parse(name)
-!x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
-use M_CLI2,only:set_args,get_args,get_args_fixed_length
-use M_CLI2,only:get_subcommand,set_mode
-character(len=*)::name! the subcommand name
-character(len=:),allocatable::help_text(:),version_text(:)
-call set_mode('response_file')
-! define version text
-version_text=[character(len=80)::&
-'@(#)PROGRAM: demo_get_subcommand >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200715 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-'']
-! general help for "demo_get_subcommand --help"
-help_text=[character(len=80)::&
-' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
-'']
-! find the subcommand name by looking for first word on command
-! not starting with dash
-name=get_subcommand()
-select case(name)
-case('run')
-help_text=[character(len=80)::&
-' ',&
-' Help for subcommand "run" ',&
-' ',&
-'']
-call set_args(&
-&'-x 1 -y 2 -z 3 --title "my title" -l F -L F',&
-&help_text,version_text)
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-case('test')
-help_text=[character(len=80)::&
-' ',&
-' Help for subcommand "test" ',&
-' ',&
-'']
-call set_args(&
-&'--title "my title" -l F -L F --testname "Test"',&
-&help_text,version_text)
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-call get_args_fixed_length('testname',testname)
-case default
-! process help and version
-call set_args(' ',help_text,version_text)
-write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']'
-write(*,'(a)')[character(len=80)::&
-' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
-'']
-stop
- end select
- end subroutine parse
+
subroutine parse()
+!! Put everything to do with command parsing here
+!!
+use M_CLI2,only:set_args,set_mode
+call set_mode([character(len=20)::'strict','ignorecase'])
+! a single call to set_args can define the options and their defaults, set help
+! text and version information, and crack command line.
+call set_args(&
+!! DEFINE COMMAND OPTIONS AND DEFAULT VALUES
+' &
+ -i 1 -j 2 -k 3 &
+ -l F -m F -n F &
+ -x 1 -y 2 -z 3 &
+ --title "my title" &
+!! ## HELP TEXT ##
+',[character(len=80)::&
+!12345678901234567890123456789012345678901234567890123456789012345678901234567890
+'NAME ',&
+' myprogram(1) - make all things possible ',&
+'SYNOPSIS ',&
+' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ',&
+' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ',&
+'DESCRIPTION ',&
+' myprogram(1) makes all things possible given stuff. ',&
+'OPTIONS ',&
+' -i,-j,-k some integer values ',&
+' -l,-m,-n some logical values ',&
+' -x,-y,-z some real values ',&
+' --title a string argument ',&
+' FILENAMES any additional strings ',&
+'EXAMPLE ',&
+' Typical usage: ',&
+' ',&
+' demo17 *.* ',&
+' ',&
+' ',&
+!! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ##
+''],[character(len=80)::&
+'@(#)PROGRAM: demo17 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200115 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+''])
+
+end subroutine parse
@@ -403,7 +284,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
33 statements
+ title=" 8.6% of total for procedures.">33 statements
@@ -336,8 +336,8 @@
Source Code
! general help for "demo_get_subcommand --help"help_text=[character(len=80)::&' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
+' * run -l -L --title -x -y -z ',&
+' * test -l -L --title ',&'']! find the subcommand name by looking for first word on command! not starting with dash
@@ -403,7 +403,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
NAME name of commandline argument to query the presence of
+
NAME name of commandline argument to query the presence of. Long
+ names should always be used.
RETURNS
@@ -184,50 +195,104 @@
RETURNS
EXAMPLE
Sample program:
programdemo_specified
-useM_CLI2, only : set_args, get_args, specified
+use, intrinsic :: iso_fortran_env, only : &
+&stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
+useM_CLI2, only : set_args, igets, rgets, specified, sget, lgetimplicitnone
-!DEFINEARGS
-integer :: flag
-integer,allocatable :: ints(:)
-real,allocatable :: two_names(:)
-!ITISABADIDEATONOTHAVETHESAMEDEFAULTVALUEFORALIASED
-!NAMESBUTCURRENTLYYOUSTILLSPECIFYTHEM
+!Defineargs
+integer,allocatable :: ints(:)
+real,allocatable :: floats(:)
+logical :: flag
+character(len=:),allocatable :: color
+character(len=:),allocatable :: list(:)
+integer :: i
+
callset_args('&
- &--flag1-f1&
- &--ints1,2,3-i1,2,3&
- &--two_names11.3-T11.3')
-
-!ASSIGNVALUESTOELEMENTSCONDITIONALLYCALLINGWITHSHORTNAME
- callget_args('flag',flag)
- if(specified('f'))callget_args('f',flag)
- callget_args('ints',ints)
- if(specified('i'))callget_args('i',ints)
- callget_args('two_names',two_names)
- if(specified('T'))callget_args('T',two_names)
-
- !IFYOUWANTTOKNOWIFGROUPSOFPARAMETERSWERESPECIFIEDUSE
+ &--color:c"red"&
+ &--flag:fF&
+ &--ints:i1,10,11&
+ &--floats:T12.3, 4.56&
+ &')
+ ints=igets('ints')
+ floats=rgets('floats')
+ flag=lget('flag')
+ color=sget('color')
+
+ write(*,*)'color=',color
+ write(*,*)'flag=',flag
+ write(*,*)'ints=',ints
+ write(*,*)'floats=',floats
+
+ write(*,*)'was -flag specified?',specified('flag')
+
+ !elemental
+ write(*,*)specified(['floats','ints '])
+
+ !Ifyouwanttoknowifgroupsofparameterswerespecifieduse!ANY(3f)andALL(3f)
- write(*,*)specified(['two_names','T '])
- write(*,*)'ANY:',any(specified(['two_names','T ']))
- write(*,*)'ALL:',all(specified(['two_names','T ']))
+ write(*,*)'ANY:',any(specified(['floats','ints ']))
+ write(*,*)'ALL:',all(specified(['floats','ints ']))
- !FORMUTUALLYEXCLUSIVE
- if(all(specified(['two_names','T '])))then
- write(*,*)'You specified both names -T and -two_names'
+ !Formutuallyexclusive
+ if(all(specified(['floats','ints '])))then
+ write(*,*)'You specified both names --ints and --floats'endif
- !FORREQUIREDPARAMETER
- if(.not.any(specified(['two_names','T '])))then
- write(*,*)'You must specify -T or -two_names'
+ !Forrequiredparameter
+ if(.not.any(specified(['floats','ints '])))then
+ write(*,*)'You must specify --ints or --floats'endif
- !USEVALUES
- write(*,*)'flag=',flag
- write(*,*)'ints=',ints
- write(*,*)'two_names=',two_names
- endprogramdemo_specified
+
+!checkifallvaluesareinrangefrom10to30andeven
+write(*,*)'are all numbers good?',all([ints>=10,ints<=30,(ints/2)*2==ints])
+
+!perhapsyouwanttocheckonevalueatatime
+doi=1,size(ints)
+ write(*,*)ints(i),[ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]
+ if(all([ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]))then
+ write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+ else
+ write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+ endif
+enddo
+
+list= [character(len=10) :: 'red','white','blue']
+if(any(color==list))then
+ write(*,*)color,'matches a value in the list'
+else
+ write(*,*)color,'not in the list'
+endif
+
+if(size(ints).eq.3)then
+ write(*,*)'ints(:) has expected number of values'
+else
+ write(*,*)'ints(:) does not have expected number of values'
+endif
+
+endprogramdemo_specified
+
Default output
+
+
color=red
+flag= F
+ints= 1 10 11
+floats= 12.3000002 4.55999994
+was -flag specified? F
+F F
+ANY: F
+ALL: F
+You must specify –ints or –floats
+ 1 F T F
+ 1 is not an even number from 10 to 30 inclusive
+ 10 T T T
+ 10 is an even number from 10 to 30 inclusive
+ 11 T T F
+ 11 is not an even number from 10 to 30 inclusive
+red matches a value in the list
+ints(:) has expected number of values
+
AUTHOR
John S. Urban, 2019
@@ -348,7 +413,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
program demo1!! @(#) using the convenience functions
-use M_CLI2,only:set_args,get_args_fixed_size,set_mode
-use M_CLI2,only:dget,iget,lget,rget,sget,cget! for scalars
-use M_CLI2,only:dgets,igets,lgets,rgets,sgets,cgets! for allocatable arrays
-implicit none
+use M_CLI2,only:set_args,get_args_fixed_size,set_mode
+use M_CLI2,only:dget,iget,lget,rget,sget,cget! for scalars
+use M_CLI2,only:dgets,igets,lgets,rgets,sgets,cgets! for allocatable arrays
+implicit none!! DECLARE "ARGS"
-real::x,y,z,point(3)
-character(len=:),allocatable::title,anytitle
-logical::l,lupper
+real::x,y,z,point(3)
+character(len=:),allocatable::title,anytitle
+logical::l,lupper
+
+print*,'demo1: using the convenience functions'call set_mode('response_file')!! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES
@@ -446,7 +448,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
program demo10
-!! @(#) full usage and even equivalencing
-use M_CLI2,only:set_args,get_args,unnamed
-use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
-use M_CLI2,only:specified! only needed if equivalence keynames
-implicit none
-integer::i
-
-!! DECLARE "ARGS"
-real::x,y,z
-real::point(3),p(3)
-character(len=80)::title
-logical::l,l_
-equivalence(point,p)
-
-!! WHEN DEFINING THE PROTOTYPE
-! o All parameters must be listed with a default value
-! o string values must be double-quoted
-! o numeric lists must be comma-delimited. No spaces are allowed
-! o long keynames must be all lowercase
-
-!! SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES
-call set_args('-x 1 -y 2 -z 3 --point -1,-2,-3 --p -1,-2,-3 --title "my title" -l F -L F')
-!! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-
-! note these are equivalenced so one of the calls must be conditional
-call get_args_fixed_size('point',point)
-if(specified('p'))call get_args_fixed_size('p',p)
-
-! if for some reason you want to use a fixed-length string use
-! get_args_fixed_length(3f) instead of get_args(3f)
-call get_args_fixed_length('title',title)
-
-call get_args('l',l)
-call get_args('L',l_)
-!! USE THE VALUES IN YOUR PROGRAM.
-write(*,*)'x=',x,'y=',y,'z=',z,'SUM=',x+y+z
-write(*,*)'point=',point,'p=',p
-write(*,*)'title=',trim(title)
-write(*,*)'l=',l,'L=',l_
-!
-! the optional unnamed values on the command line are
-! accumulated in the character array "UNNAMED"
-if(size(unnamed)>0)then
- write(*,'(a)')'files:'
-write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
-endif
-
-end program demo10
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
\ No newline at end of file
diff --git a/docs/fpm-ford/program/demo11.html b/docs/fpm-ford/program/demo11.html
index feb83d7e..ad45e833 100644
--- a/docs/fpm-ford/program/demo11.html
+++ b/docs/fpm-ford/program/demo11.html
@@ -89,7 +89,7 @@
demo11 Program
33 statements
+ title=" 4.6% of total for programs.">39 statements
character(len=:),allocatable::namecharacter(len=:),allocatable::string
+character(len=:),allocatable::list(:)character(len=80)::readme!(3)integer::i
-! M_CLI2 does not have validators except for SPECIFIED(3f) and
-! a check whether the input conforms to the type with get_args(3f)
-! and the convenience functions like inum(3f). But Fortran already
-! has powerful validation capabilities, especially with the use
-! of logical expressions, and ANY(3f) and ALL(3f).
+print*,'demo11: examples of validating values with ALL(3f) and ANY(3f)'
-! A somewhat contrived example of using ALL(3f):
+! M_CLI2 intentionally does not have complex validators except for SPECIFIED(3f) and
+! a check whether the input conforms to the type with get_args(3f)
+! or the convenience functions like inum(3f).
+!
+! Fortran already has powerful validation capabilities. Logical
+! expressions ANY(3f) and ALL(3f) are standard Fortran features easily
+! allow performing the common validations for command line arguments
+! without having to learn any additional syntax or methods.
-! even number from 10 to 30 inclusivedo i=1,100if(all([i>=10,i<=30,(i/2)*2==i]))then
- write(*,*)'good',i
+ write(*,*)i,' is an even number from 10 to 30 inclusive'endif
-enddo
+enddo
-! an example of using ANY(3f)
-
-! matchedname='red'
-if(any(name==[character(len=10)::'red','white','blue']))then
- write(*,*)'matches ',name
-endif
-! not matched
-name='teal'
-if(any(name==[character(len=10)::'red','white','blue']))then
- write(*,*)'matches ',name
+list=[character(len=10)::'red','white','blue']
+if(any(name==list))then
+ write(*,*)name,' matches a value in the list'
+else
+ write(*,*)name,' not in the list'
+endif
+
+if(size(list).eq.3)then
+ write(*,*)' list has expected number of values'
+else
+ write(*,*)' list does not have expected number of values'endif! and even user-defined types can be processed by reading the input
@@ -544,7 +566,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo12.html b/docs/fpm-ford/program/demo12.html
index 39965d1e..5c0171dc 100644
--- a/docs/fpm-ford/program/demo12.html
+++ b/docs/fpm-ford/program/demo12.html
@@ -89,7 +89,7 @@
demo12 Program
11 statements
+ title=" 1.4% of total for programs.">12 statements
@(#) using the unnamed parameters as filenames
- For example, this should list the files in the current directory
- demo17 *
-Define and parse command line
+ For example, this should list the files in the current directory
+
demo17 *
+
+
+
Also demonstrates setting –help and –version text.
+
demo17 --help
+demo17 --version
+demo17 --usage
+
+
+
Define and parse command line
Get argument values
All done cracking the command line use the values in your program.
The optional unnamed values on the command line are
@@ -224,13 +232,13 @@
program demo17!! @(#) using the unnamed parameters as filenames!! For example, this should list the files in the current directory
+!!!! demo17 *
+!!
+!! Also demonstrates setting --help and --version text.
+!!
+!! demo17 --help
+!! demo17 --version
+!! demo17 --usage
+!!use M_CLI2,only:get_argsuse M_CLI2,only:sget,lget,iget,rget,dget,cgetuse M_CLI2,only:sgets,lgets,igets,rgets,dgets,cgets
@@ -565,12 +581,17 @@
Source Code
!! The optional unnamed values on the command line are!! accumulated in the character array "UNNAMED" which was !! renamed to "FILENAMES" on the use statement
-if(size(filenames)>0)then
- print all,'files:'
-print'(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
-endif
+if(allocated(filenames))then
+ if(size(filenames)>0)then
+ print all,'files:'
+print'(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
+endif
+ endif
+
+! alternate method, additionally can be used when desired result is numeric
+! by using igets(3f), rgets(3f), ... instead of sgets(3f).
-fnames=sgets()! also gets all the unnamed arguments
+fnames=sgets()! also gets all the unnamed argumentsif(size(fnames)>0)then print all,'files:'print'(i6.6,1x,3a)',(indx,'[',fnames(indx),']',indx=1,size(fnames))
@@ -582,6 +603,8 @@
Source Code
!!use M_CLI2,only:set_args,set_modecall set_mode([character(len=20)::'strict','ignorecase'])
+! a single call to set_args can define the options and their defaults, set help
+! text and version information, and crack command line.call set_args(&!! DEFINE COMMAND OPTIONS AND DEFAULT VALUES' &
@@ -642,7 +665,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
character(len=80)::titlelogical::l,l_
+print*,'demo2: all parsing and **help** and **version** information in a contained procedure'
+
call parse()!! DEFINE AND PARSE COMMAND LINE!! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.
@@ -461,58 +463,58 @@
Source Code
endifcontains
- subroutine parse()
-!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
-use M_CLI2,only:set_args,get_args
-use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
-character(len=:),allocatable::help_text(:),version_text(:)
-
-!! DEFINE COMMAND PROTOTYPE
-!! o All parameters must be listed with a default value
-!! o string values must be double-quoted
-!! o numeric lists must be comma-delimited. No spaces are allowed
-!! o long keynames must be all lowercase
-
-character(len=*),parameter::cmd='&
+subroutine parse()
+!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
+use M_CLI2,only:set_args,get_args
+use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
+character(len=:),allocatable::help_text(:),version_text(:)
+
+!! DEFINE COMMAND PROTOTYPE
+!! o All parameters must be listed with a default value
+!! o string values must be double-quoted
+!! o numeric lists must be comma-delimited. No spaces are allowed
+!! o long keynames must be all lowercase
+
+character(len=*),parameter::cmd='& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title "my title" & & -l F -L F & & '
-help_text=[character(len=80)::&
-'NAME ',&
-' myprocedure(1) - make all things possible ',&
-'SYNOPSIS ',&
-' function myprocedure(stuff) ',&
-' class(*) :: stuff ',&
-'DESCRIPTION ',&
-' myprocedure(1) makes all things possible given STUFF ',&
-'OPTIONS ',&
-' STUFF things to do things to ',&
-'RETURNS ',&
-' MYPROCEDURE the answers you want ',&
-'EXAMPLE ',&
-'']
-
-version_text=[character(len=80)::&
-'@(#)PROGRAM: demo2 >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200115 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-'']
-
-call set_args(cmd,help_text,version_text)
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-call get_args_fixed_size('point',point)
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-
-end subroutine parse
+help_text=[character(len=80)::&
+'NAME ',&
+' myprocedure(1) - make all things possible ',&
+'SYNOPSIS ',&
+' function myprocedure(stuff) ',&
+' class(*) :: stuff ',&
+'DESCRIPTION ',&
+' myprocedure(1) makes all things possible given STUFF ',&
+'OPTIONS ',&
+' STUFF things to do things to ',&
+'RETURNS ',&
+' MYPROCEDURE the answers you want ',&
+'EXAMPLE ',&
+'']
+
+version_text=[character(len=80)::&
+'@(#)PROGRAM: demo2 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200115 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+'']
+
+call set_args(cmd,help_text,version_text)
+call get_args('x',x)
+call get_args('y',y)
+call get_args('z',z)
+call get_args_fixed_size('point',point)
+call get_args_fixed_length('title',title)
+call get_args('l',l)
+call get_args('L',l_)
+
+end subroutine parseend program demo2
@@ -534,7 +536,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo3.html b/docs/fpm-ford/program/demo3.html
index 98947895..7d82c16e 100644
--- a/docs/fpm-ford/program/demo3.html
+++ b/docs/fpm-ford/program/demo3.html
@@ -89,7 +89,7 @@
demo3 Program
12 statements
+ title=" 1.4% of total for programs.">12 statements
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo3~2.html b/docs/fpm-ford/program/demo3~2.html
index 93dc8783..3c325214 100644
--- a/docs/fpm-ford/program/demo3~2.html
+++ b/docs/fpm-ford/program/demo3~2.html
@@ -89,7 +89,7 @@
demo3 Program
12 statements
+ title=" 1.5% of total for programs.">13 statements
@@ -343,11 +343,19 @@
Source Code
logical::lreal::sizecharacter(len=:),allocatable::title
+
+print*,'demo3: just the bare essentials'
+
+! define the command, set default values and read the command linecall set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
+
+! get the valuescall get_args('x',x,'y',y,'l',l,'size',size)! all the non-allocatables
-call get_args('title',title)
-! Done. all variables set and of the right type
+call get_args('title',title)! do allocatables one at a time
+
+! Done. All variables set and of the requested typewrite(*,'(*("[",g0,"]":,1x))')x,y,size,l,title
+
end program demo3
@@ -368,7 +376,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo4.html b/docs/fpm-ford/program/demo4.html
index 26453eb7..d9464e73 100644
--- a/docs/fpm-ford/program/demo4.html
+++ b/docs/fpm-ford/program/demo4.html
@@ -89,7 +89,7 @@
demo4 Program
18 statements
+ title=" 2.3% of total for programs.">19 statements
character(len=*),parameter::form='("(",g0,",",g0,"i)":,1x)'character(len=*),parameter::forms='(*("(",g0,",",g0,"i)":,",",1x))'
+print*,'demo4: COMPLEX argument example'
+
! COMPLEX VALUES!! o parenthesis are optional and are ignored in complex values.
@@ -434,7 +436,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo5.html b/docs/fpm-ford/program/demo5.html
index 8f5e4fc3..f2f5e1f7 100644
--- a/docs/fpm-ford/program/demo5.html
+++ b/docs/fpm-ford/program/demo5.html
@@ -89,7 +89,7 @@
demo5 Program
44 statements
+ title=" 5.4% of total for programs.">45 statements
character(len=80)::title,testnamelogical::l,l_
+print*,'demo6: creating subcommands'
+
version_text=[character(len=80)::&'@(#)PROGRAM: demo6 >',&'@(#)DESCRIPTION: My demo program >',&
@@ -632,7 +634,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo7.html b/docs/fpm-ford/program/demo7.html
index 7436795f..9f5245e2 100644
--- a/docs/fpm-ford/program/demo7.html
+++ b/docs/fpm-ford/program/demo7.html
@@ -89,7 +89,7 @@
demo7 Program
30 statements
+ title=" 3.7% of total for programs.">31 statements
@@ -423,6 +423,8 @@
Source Code
complex,allocatable::complexs(:)character(len=:),allocatable::characters(:)! allocatable array with allocatable length
+print*,'demo7: controlling array delimiter characters'
+
! ARRAY DELIMITERS!! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f)
@@ -466,7 +468,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo8.html b/docs/fpm-ford/program/demo8.html
index 71bb073f..61f3ea1d 100644
--- a/docs/fpm-ford/program/demo8.html
+++ b/docs/fpm-ford/program/demo8.html
@@ -89,7 +89,7 @@
demo8 Program
12 statements
+ title=" 1.5% of total for programs.">13 statements
real::sizecharacter(len=80)::titlecharacter(len=*),parameter::pairs='(1("[",g0,"=",g0,"]":,1x))'
+
+print*,'demo8: Sometimes you can put multiple values on getargs(3f)'
+
! DEFINE COMMAND AND PARSE COMMAND LINE! set all values, double-quote stringscall set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
+
! GET THE VALUES! only fixed scalar values (including only character variables that! are fixed length) may be combined in one GET_ARGS(3f) callcall get_args('x',x,'y',y,'l',l,'size',size,'title',title)
+
! USE THE VALUESwrite(*,fmt=pairs)'X',x,'Y',y,'size',size,'L',l,'TITLE',title
+
end program demo8
@@ -391,7 +397,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo9.html b/docs/fpm-ford/program/demo9.html
index bfd5e595..3b96677f 100644
--- a/docs/fpm-ford/program/demo9.html
+++ b/docs/fpm-ford/program/demo9.html
@@ -89,7 +89,7 @@
demo9 Program
12 statements
+ title=" 1.5% of total for programs.">13 statements
@(#) long and short names using –LONGNAME:SHORTNAME
-
When all keys have a long and short name “strict mode” is invoked where
- “-” is required for short names; and Boolean values may be bundled
- together. For example:
+
When all keys have a long and short name and “strict mode” is invoked
+ where “-” is required for short names and “–” for long names Boolean
+ values may be bundled together. For example:
program demo9!> @(#) long and short names using --LONGNAME:SHORTNAME!!
-!! When all keys have a long and short name "strict mode" is invoked where
-!! "-" is required for short names; and Boolean values may be bundled
-!! together. For example:
+!! When all keys have a long and short name and "strict mode" is invoked
+!! where "-" is required for short names and "--" for long names Boolean
+!! values may be bundled together. For example:!!!! demo9 -XYZ!!
-use M_CLI2,only:set_args,sget,rget,lget
+use M_CLI2,only:set_args,sget,rget,lget,set_modeimplicit nonecharacter(len=*),parameter::all='(*(g0))'
+
+print*,'demo9: long and short names using --LONGNAME:SHORTNAME'
+!call set_mode('strict')call set_args(' & & --length:l 10 & & --height:h 12.45 &
@@ -312,7 +315,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
use M_CLI2,only:filenames=>unnamed,set_args,get_argsimplicit noneinteger::i
-! DEFINE ARGS
+! Define ARGSreal::x,y,zreal,allocatable::p(:)character(len=:),allocatable::titlelogical::l,lbig
-! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-! o only quote strings and use double-quotes
-! o set all logical values to F or T.
-call set_args(' &
- & -x 1 -y 2 -z 3 &
- & -p -1,-2,-3 &
+! Define and parse (to set initial values) command line
+! o only quote strings and use double-quotes
+! o set all logical values to F or T.
+call set_args(' &
+ & -x 1 -y 2 -z 3 &
+ & -p -1,-2,-3 & & --title "my title" &
- & -l F -L F &
- & --label " " &
+ & -l F -L F &
+ & --label " " & & ')
-! ASSIGN VALUES TO ELEMENTS
-! SCALARS
-call get_args('x',x,'y',y,'z',z)
-call get_args('l',l)
-call get_args('L',lbig)
-! ALLOCATABLE STRING
+! Assign values to elements
+! Scalars
+call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+! Allocatable stringcall get_args('title',title)
-! NON-ALLOCATABLE ARRAYS
+! Allocatable arrayscall get_args('p',p)
-! USE VALUES
+! Use valueswrite(*,'(1x,g0,"=",g0)')'x',x,'y',y,'z',zwrite(*,*)'p=',pwrite(*,*)'title=',title
@@ -446,7 +444,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo_get_args_fixed_length.html b/docs/fpm-ford/program/demo_get_args_fixed_length.html
index 459786d1..6d2e4765 100644
--- a/docs/fpm-ford/program/demo_get_args_fixed_length.html
+++ b/docs/fpm-ford/program/demo_get_args_fixed_length.html
@@ -89,7 +89,7 @@
demo_get_args_fixed_length Program
8 statements
+ title=" 1.0% of total for programs.">8 statements
!x! You can call this program which has two subcommands (run, test),!x! like this:!x! demo_get_subcommand --help
-!x! demo_get_subcommand run -x -y -z -title -l -L
-!x! demo_get_subcommand test -title -l -L -testname
+!x! demo_get_subcommand run -x -y -z --title -l -L
+!x! demo_get_subcommand test --title -l -L --testname!x! demo_get_subcommand run --helpimplicit none!x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
@@ -489,8 +489,8 @@
Source Code
! general help for "demo_get_subcommand --help"help_text=[character(len=80)::&' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
+' * run -l -L --title -x -y -z ',&
+' * test -l -L --title ',&'']! find the subcommand name by looking for first word on command! not starting with dash
@@ -556,7 +556,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
! enable use of response filescall set_mode('response_file')!
-! Any dash in a keyname is treated as an underscore
+! Any dash in a keyword is treated as an underscorecall set_mode('underdash')!
-! The case of long keynames are ignored.
+! The case of long keywords are ignored.! Values and short names remain case-sensitivecall set_mode('ignorecase')!! short single-character boolean keys may be bundled! but it is required that a single dash is used for
-! short keys and a double dash for long keynames.
+! short keys and a double dash for long keywords.call set_mode('strict')!call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
@@ -311,7 +311,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/demo_specified.html b/docs/fpm-ford/program/demo_specified.html
index 13090266..796c55c5 100644
--- a/docs/fpm-ford/program/demo_specified.html
+++ b/docs/fpm-ford/program/demo_specified.html
@@ -89,7 +89,7 @@
demo_specified Program
26 statements
+ title=" 5.9% of total for programs.">50 statements
program demo_specified
-use M_CLI2,only:set_args,get_args,specified
+use,intrinsic::iso_fortran_env,only:&
+&stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT
+use M_CLI2,only:set_args,igets,rgets,specified,sget,lgetimplicit none
-! DEFINE ARGS
-integer::flag
-integer,allocatable::ints(:)
-real,allocatable::two_names(:)
-! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED
-! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM
+! Define args
+integer,allocatable::ints(:)
+real,allocatable::floats(:)
+logical::flag
+character(len=:),allocatable::color
+character(len=:),allocatable::list(:)
+integer::i
+
call set_args('&
- & --flag 1 -f 1 &
- & --ints 1,2,3 -i 1,2,3 &
- & --two_names 11.3 -T 11.3')
-
-! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME
-call get_args('flag',flag)
-if(specified('f'))call get_args('f',flag)
-call get_args('ints',ints)
-if(specified('i'))call get_args('i',ints)
-call get_args('two_names',two_names)
-if(specified('T'))call get_args('T',two_names)
-
-! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE
+ & --color:c "red" &
+ & --flag:f F &
+ & --ints:i 1,10,11 &
+ & --floats:T 12.3, 4.56 &
+ & ')
+ints=igets('ints')
+floats=rgets('floats')
+flag=lget('flag')
+color=sget('color')
+
+write(*,*)'color=',color
+write(*,*)'flag=',flag
+write(*,*)'ints=',ints
+write(*,*)'floats=',floats
+
+write(*,*)'was -flag specified?',specified('flag')
+
+! elemental
+write(*,*)specified(['floats','ints '])
+
+! If you want to know if groups of parameters were specified use! ANY(3f) and ALL(3f)
-write(*,*)specified(['two_names','T '])
-write(*,*)'ANY:',any(specified(['two_names','T ']))
-write(*,*)'ALL:',all(specified(['two_names','T ']))
+write(*,*)'ANY:',any(specified(['floats','ints ']))
+write(*,*)'ALL:',all(specified(['floats','ints ']))
-! FOR MUTUALLY EXCLUSIVE
-if(all(specified(['two_names','T '])))then
- write(*,*)'You specified both names -T and -two_names'
+! For mutually exclusive
+if(all(specified(['floats','ints '])))then
+ write(*,*)'You specified both names --ints and --floats'endif
-! FOR REQUIRED PARAMETER
-if(.not.any(specified(['two_names','T '])))then
- write(*,*)'You must specify -T or -two_names'
+! For required parameter
+if(.not.any(specified(['floats','ints '])))then
+ write(*,*)'You must specify --ints or --floats'endif
-! USE VALUES
-write(*,*)'flag=',flag
-write(*,*)'ints=',ints
-write(*,*)'two_names=',two_names
-end program demo_specified
+
+! check if all values are in range from 10 to 30 and even
+write(*,*)'are all numbers good?',all([ints>=10,ints<=30,(ints/2)*2==ints])
+
+! perhaps you want to check one value at a time
+do i=1,size(ints)
+write(*,*)ints(i),[ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]
+if(all([ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]))then
+ write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+else
+ write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+endif
+ enddo
+
+list=[character(len=10)::'red','white','blue']
+if(any(color==list))then
+ write(*,*)color,'matches a value in the list'
+else
+ write(*,*)color,'not in the list'
+endif
+
+ if(size(ints).eq.3)then
+ write(*,*)'ints(:) has expected number of values'
+else
+ write(*,*)'ints(:) does not have expected number of values'
+endif
+
+ end program demo_specified
@@ -361,7 +450,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/program/test_ignorecase.html b/docs/fpm-ford/program/test_ignorecase.html
index b0553f5d..5a01d1bb 100644
--- a/docs/fpm-ford/program/test_ignorecase.html
+++ b/docs/fpm-ford/program/test_ignorecase.html
@@ -89,7 +89,7 @@
test_ignorecase Program
54 statements
+ title=" 6.3% of total for programs.">53 statements
use M_CLI2,only:set_args,sget,igets,rgets,dgets,lget,set_modeimplicit nonecharacter(len=*),parameter::it='(1x,*(g0,1x))'
-logical,parameter::T=.true.,F=.false.character(len=:),allocatable::whichonecharacter(len=:),allocatable::arr(:)call set_mode('ignorecase')call set_args(' --type run -a "a AA a" -b "B bb B" -A AAA -B BBB --longa:O " OoO " --longb:X "xXx"')whichone=sget('type')
-arr=[character(len=10)::sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X')]
+arr=[character(len=17)::sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X')]select case(whichone)
-case('one');call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
-case('two');call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
-case('three');call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
-case('four');call testit(whichone,all([character(len=10)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
-case('five');call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB',&
+case('one');call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
+case('two');call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+case('three');call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+case('four');call testit(whichone,all([character(len=17)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
+case('five');call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB',&&'a b c d e f g h i','xXx','a b c d e f g h i','xXx']==arr))case('six');!call testit(whichone, all(arr))case('run')
@@ -539,7 +502,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 01:24
Documentation generated by
FORD
- on 2023-02-08 04:39
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/search.html b/docs/fpm-ford/search.html
index c4f23b51..9585d687 100644
--- a/docs/fpm-ford/search.html
+++ b/docs/fpm-ford/search.html
@@ -113,7 +113,7 @@
Search Results
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo1.f90.html b/docs/fpm-ford/sourcefile/demo1.f90.html
index 80381198..df3ec369 100644
--- a/docs/fpm-ford/sourcefile/demo1.f90.html
+++ b/docs/fpm-ford/sourcefile/demo1.f90.html
@@ -90,7 +90,7 @@
demo1.f90
22 statements
+ title=" 0.7% of total for source files.">23 statements
@@ -209,45 +209,47 @@
Source Code
program demo1!! @(#) using the convenience functions
-use M_CLI2,only:set_args,get_args_fixed_size,set_mode
-use M_CLI2,only:dget,iget,lget,rget,sget,cget! for scalars
-use M_CLI2,only:dgets,igets,lgets,rgets,sgets,cgets! for allocatable arrays
-implicit none
+use M_CLI2,only:set_args,get_args_fixed_size,set_mode
+use M_CLI2,only:dget,iget,lget,rget,sget,cget! for scalars
+use M_CLI2,only:dgets,igets,lgets,rgets,sgets,cgets! for allocatable arrays
+implicit none!! DECLARE "ARGS"
-real::x,y,z,point(3)
-character(len=:),allocatable::title,anytitle
-logical::l,lupper
+real::x,y,z,point(3)
+character(len=:),allocatable::title,anytitle
+logical::l,lupper
-call set_mode('response_file')
-!! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES
-call set_args('-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T "my title" --anytitle:a "my title" -l F -L F')
-
-!! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
-x=rget('x')
-y=rget('y')
-z=rget('z')
-l=lget('l')
-lupper=lget('L')
-title=sget('title')
-anytitle=sget('anytitle')
-
-! With a fixed-size array to ensure the correct number of values are input use
-call get_args_fixed_size('point',point)
-
-!! USE THE VALUES IN YOUR PROGRAM.
-write(*,'(*(g0:,1x))')'x=',x,'y=',y,'z=',z,'SUM=',x+y+z,' point=',point
-write(*,'(*(g0:,1x))')'title=',trim(title),' l=',l,'L=',lupper
-write(*,'(*(g0:,1x))')'anytitle=',trim(anytitle)
-
-end program demo1
+print*,'demo1: using the convenience functions'
+
+call set_mode('response_file')
+!! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES
+call set_args('-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T "my title" --anytitle:a "my title" -l F -L F')
+
+!! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
+x=rget('x')
+y=rget('y')
+z=rget('z')
+l=lget('l')
+lupper=lget('L')
+title=sget('title')
+anytitle=sget('anytitle')
+
+! With a fixed-size array to ensure the correct number of values are input use
+call get_args_fixed_size('point',point)
+
+!! USE THE VALUES IN YOUR PROGRAM.
+write(*,'(*(g0:,1x))')'x=',x,'y=',y,'z=',z,'SUM=',x+y+z,' point=',point
+write(*,'(*(g0:,1x))')'title=',trim(title),' l=',l,'L=',lupper
+write(*,'(*(g0:,1x))')'anytitle=',trim(anytitle)
-!! NOTES: WHEN DEFINING THE PROTOTYPE
-! o All parameters must be listed with a default value
-! o string values must be double-quoted
-! o numeric lists must be comma-delimited. No spaces are allowed
-! o long keynames must be all lowercase but may be followed by :LETTER where LETTER is a
-! single letter that may be of any case that will act as a short name for the same value.
+end program demo1
+
+!! NOTES: WHEN DEFINING THE PROTOTYPE
+! o All parameters must be listed with a default value
+! o string values must be double-quoted
+! o numeric lists must be comma-delimited. No spaces are allowed
+! o long keynames must be all lowercase but may be followed by :LETTER where LETTER is a
+! single letter that may be of any case that will act as a short name for the same value.
@@ -266,7 +268,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
program demo10
-!! @(#) full usage and even equivalencing
-use M_CLI2,only:set_args,get_args,unnamed
-use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
-use M_CLI2,only:specified! only needed if equivalence keynames
-implicit none
-integer::i
-
-!! DECLARE "ARGS"
-real::x,y,z
-real::point(3),p(3)
-character(len=80)::title
-logical::l,l_
-equivalence(point,p)
-
-!! WHEN DEFINING THE PROTOTYPE
-! o All parameters must be listed with a default value
-! o string values must be double-quoted
-! o numeric lists must be comma-delimited. No spaces are allowed
-! o long keynames must be all lowercase
-
-!! SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES
-call set_args('-x 1 -y 2 -z 3 --point -1,-2,-3 --p -1,-2,-3 --title "my title" -l F -L F')
-!! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-
-! note these are equivalenced so one of the calls must be conditional
-call get_args_fixed_size('point',point)
-if(specified('p'))call get_args_fixed_size('p',p)
-
-! if for some reason you want to use a fixed-length string use
-! get_args_fixed_length(3f) instead of get_args(3f)
-call get_args_fixed_length('title',title)
-
-call get_args('l',l)
-call get_args('L',l_)
-!! USE THE VALUES IN YOUR PROGRAM.
-write(*,*)'x=',x,'y=',y,'z=',z,'SUM=',x+y+z
-write(*,*)'point=',point,'p=',p
-write(*,*)'title=',trim(title)
-write(*,*)'l=',l,'L=',l_
-!
-! the optional unnamed values on the command line are
-! accumulated in the character array "UNNAMED"
-if(size(unnamed)>0)then
- write(*,'(a)')'files:'
-write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
-endif
-
-end program demo10
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
\ No newline at end of file
diff --git a/docs/fpm-ford/sourcefile/demo11.f90.html b/docs/fpm-ford/sourcefile/demo11.f90.html
index 3650f841..1f876071 100644
--- a/docs/fpm-ford/sourcefile/demo11.f90.html
+++ b/docs/fpm-ford/sourcefile/demo11.f90.html
@@ -90,7 +90,7 @@
demo11.f90
33 statements
+ title=" 1.1% of total for source files.">39 statements
@@ -221,71 +221,75 @@
Source Code
character(len=:),allocatable::namecharacter(len=:),allocatable::string
-character(len=80)::readme!(3)
-integer::i
-
-! M_CLI2 does not have validators except for SPECIFIED(3f) and
-! a check whether the input conforms to the type with get_args(3f)
-! and the convenience functions like inum(3f). But Fortran already
-! has powerful validation capabilities, especially with the use
-! of logical expressions, and ANY(3f) and ALL(3f).
-
-! A somewhat contrived example of using ALL(3f):
-
-! even number from 10 to 30 inclusive
-do i=1,100
-if(all([i>=10,i<=30,(i/2)*2==i]))then
- write(*,*)'good',i
-endif
-enddo
-
-! an example of using ANY(3f)
-
-! matched
+character(len=:),allocatable::list(:)
+character(len=80)::readme!(3)
+integer::i
+
+print*,'demo11: examples of validating values with ALL(3f) and ANY(3f)'
+
+! M_CLI2 intentionally does not have complex validators except for SPECIFIED(3f) and
+! a check whether the input conforms to the type with get_args(3f)
+! or the convenience functions like inum(3f).
+!
+! Fortran already has powerful validation capabilities. Logical
+! expressions ANY(3f) and ALL(3f) are standard Fortran features easily
+! allow performing the common validations for command line arguments
+! without having to learn any additional syntax or methods.
+
+do i=1,100
+if(all([i>=10,i<=30,(i/2)*2==i]))then
+ write(*,*)i,' is an even number from 10 to 30 inclusive'
+endif
+enddo
+name='red'
-if(any(name==[character(len=10)::'red','white','blue']))then
- write(*,*)'matches ',name
-endif
-! not matched
-name='teal'
-if(any(name==[character(len=10)::'red','white','blue']))then
- write(*,*)'matches ',name
-endif
-
-! and even user-defined types can be processed by reading the input
-! as a string and using a NAMELIST(3f) group to convert it. Note that
-! if input values are strings that have to be quoted (ie. more than one
-! word) or contain characters special to the shell that how you have to
-! quote the command line can get complicated.
-
-string='10,20,"green"'
-
-readme='&nml_dot dot='//string//'/'
+list=[character(len=10)::'red','white','blue']
+if(any(name==list))then
+ write(*,*)name,' matches a value in the list'
+else
+ write(*,*)name,' not in the list'
+endif
+
+if(size(list).eq.3)then
+ write(*,*)' list has expected number of values'
+else
+ write(*,*)' list does not have expected number of values'
+endif
+
+! and even user-defined types can be processed by reading the input
+! as a string and using a NAMELIST(3f) group to convert it. Note that
+! if input values are strings that have to be quoted (ie. more than one
+! word) or contain characters special to the shell that how you have to
+! quote the command line can get complicated.
-! some compilers might require the input to be on three lines
-!readme=[ character(len=80) ::&
-!'&nml_dot', &
-!'dot='//string//' ,', &
-!'/']
-
-read(readme,nml=nml_dot)
-
-write(*,*)dot%x,dot%y,dot%color
-! or
-write(*,nml_dot)
+string='10,20,"green"'
+
+readme='&nml_dot dot='//string//'/'
+
+! some compilers might require the input to be on three lines
+!readme=[ character(len=80) ::&
+!'&nml_dot', &
+!'dot='//string//' ,', &
+!'/']
+
+read(readme,nml=nml_dot)
-! Hopefully it is obvious how the options can be read from values gotten
-! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f)
-! in the first case, so this example just uses simple declarations to highlight
-! some useful Fortran expressions that can be useful for validating the input
-! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups.
-
-! another alternative would be to validate expressions from strings using M_calculator(3f)
-! but I find it easier to validate the values using regular Fortran code than doing it
-! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by
-! M_CLI2(3f) doing validation in the input forms themselves would be more desirable.
-
-end program demo11
+write(*,*)dot%x,dot%y,dot%color
+! or
+write(*,nml_dot)
+
+! Hopefully it is obvious how the options can be read from values gotten
+! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f)
+! in the first case, so this example just uses simple declarations to highlight
+! some useful Fortran expressions that can be useful for validating the input
+! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups.
+
+! another alternative would be to validate expressions from strings using M_calculator(3f)
+! but I find it easier to validate the values using regular Fortran code than doing it
+! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by
+! M_CLI2(3f) doing validation in the input forms themselves would be more desirable.
+
+end program demo11
@@ -304,7 +308,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo12.f90.html b/docs/fpm-ford/sourcefile/demo12.f90.html
index dd08fae0..9e854fd4 100644
--- a/docs/fpm-ford/sourcefile/demo12.f90.html
+++ b/docs/fpm-ford/sourcefile/demo12.f90.html
@@ -90,7 +90,7 @@
demo12.f90
11 statements
+ title=" 0.3% of total for source files.">12 statements
@@ -211,19 +211,21 @@
Source Code
!! @(#) using the convenience functionsuse M_CLI2,only:set_args,set_mode,rgetimplicit none
-real::x,y,z
+real::x,y,z
-!! ENABLE USING RESPONSE FILES
-call set_mode('response file')
-
-call set_args('-x 1.1 -y 2e3 -z -3.9 ')
-x=rget('x')
-y=rget('y')
-z=rget('z')
-!! USE THE VALUES IN YOUR PROGRAM.
-write(*,'(*(g0:,1x))')'x=',x,'y=',y,'z=',z,'SUM=',x+y+z
-
-end program demo12
+print*,'demo12: using the convenience functions'
+
+!! ENABLE USING RESPONSE FILES
+call set_mode('response file')
+
+call set_args('-x 1.1 -y 2e3 -z -3.9 ')
+x=rget('x')
+y=rget('y')
+z=rget('z')
+!! USE THE VALUES IN YOUR PROGRAM.
+write(*,'(*(g0:,1x))')'x=',x,'y=',y,'z=',z,'SUM=',x+y+z
+
+end program demo12
@@ -242,7 +244,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo13.f90.html b/docs/fpm-ford/sourcefile/demo13.f90.html
index 3d0a5c7e..644bfdbc 100644
--- a/docs/fpm-ford/sourcefile/demo13.f90.html
+++ b/docs/fpm-ford/sourcefile/demo13.f90.html
@@ -90,7 +90,7 @@
demo13.f90
9 statements
+ title=" 0.3% of total for source files.">10 statements
@@ -220,11 +220,14 @@
Source Code
use M_CLI2,only:set_args,lget,set_modeimplicit nonecharacter(len=*),parameter::all='(*(g0))'
-call set_mode('underdash')
-call set_args(' --switch_X:X F --switch-Y:Y F ')
-print all,'--switch_X or -X ... ',lget('switch_X')
-print all,'--switch_Y or -Y ... ',lget('switch_Y')
-end program demo13
+
+print*,'demo13: underdash mode'
+
+call set_mode('underdash')
+call set_args(' --switch_X:X F --switch-Y:Y F ')
+print all,'--switch_X or -X ... ',lget('switch_X')
+print all,'--switch_Y or -Y ... ',lget('switch_Y')
+end program demo13
@@ -243,7 +246,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo14.f90.html b/docs/fpm-ford/sourcefile/demo14.f90.html
index 2367d556..cc3b97d5 100644
--- a/docs/fpm-ford/sourcefile/demo14.f90.html
+++ b/docs/fpm-ford/sourcefile/demo14.f90.html
@@ -90,7 +90,7 @@
demo14.f90
8 statements
+ title=" 0.3% of total for source files.">9 statements
@@ -222,10 +222,13 @@
Source Code
use M_CLI2,only:set_args,lget,set_modeimplicit nonecharacter(len=*),parameter::all='(*(g0))'
-call set_mode('ignorecase')
-call set_args(' --longName:N F ')
-print all,'--longName or -N ... ',lget('longName')
-end program demo14
+
+print*,'demo14: ignorecase mode'
+
+call set_mode('ignorecase')
+call set_args(' --longName:N F ')
+print all,'--longName or -N ... ',lget('longName')
+end program demo14
@@ -244,7 +247,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo15.f90.html b/docs/fpm-ford/sourcefile/demo15.f90.html
index e696eab8..432e4515 100644
--- a/docs/fpm-ford/sourcefile/demo15.f90.html
+++ b/docs/fpm-ford/sourcefile/demo15.f90.html
@@ -90,7 +90,7 @@
demo15.f90
8 statements
+ title=" 0.3% of total for source files.">9 statements
@@ -223,10 +223,13 @@
Source Code
use M_CLI2,only:set_args,lget,set_modeimplicit nonecharacter(len=*),parameter::all='(*(g0))'
-call set_mode('strict')
-call set_args(' -o F -t F -x F --ox F')
-print all,'o=',lget('o'),' t=',lget('t'),' x=',lget('x'),' ox=',lget('ox')
-end program demo15
+
+print*,'demo15: strict mode'
+
+call set_mode('strict')
+call set_args(' -o F -t F -x F --ox F')
+print all,'o=',lget('o'),' t=',lget('t'),' x=',lget('x'),' ox=',lget('ox')
+end program demo15
@@ -245,7 +248,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo16.f90.html b/docs/fpm-ford/sourcefile/demo16.f90.html
index 0fb2d435..de2b30a6 100644
--- a/docs/fpm-ford/sourcefile/demo16.f90.html
+++ b/docs/fpm-ford/sourcefile/demo16.f90.html
@@ -256,7 +256,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 09:50
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo17.f90.html b/docs/fpm-ford/sourcefile/demo17.f90.html
index 2722acdd..f7dd7678 100644
--- a/docs/fpm-ford/sourcefile/demo17.f90.html
+++ b/docs/fpm-ford/sourcefile/demo17.f90.html
@@ -90,7 +90,7 @@
demo17.f90
42 statements
+ title=" 1.3% of total for source files.">44 statements
@@ -210,99 +210,114 @@
Source Code
program demo17!! @(#) using the unnamed parameters as filenames!! For example, this should list the files in the current directory
-!! demo17 *
-use M_CLI2,only:get_args
-use M_CLI2,only:sget,lget,iget,rget,dget,cget
-use M_CLI2,only:sgets,lgets,igets,rgets,dgets,cgets
-use M_CLI2,only:filenames=>unnamed
-implicit none
-type(character(len=*)),parameter::all='(*(g0))'
-type(integer)::indx
-
-!! argument values to set
-type(integer)::i,j,k
-type(real)::x,y,z
-type(character(len=:)),allocatable::title
-type(logical)::l,m,n
-type(character(len=:)),allocatable::fnames(:)
-
-print all,'demo17: using the unnamed parameters as filenames'
-print all,'example: demo17 -x 100 * '
-
-call parse()!! Define and parse command line
-!! Get argument values
-call get_args('x',x,'y',y,'z',z)
-call get_args('i',i,'j',j,'k',k)
-call get_args('l',l,'m',m,'n',n)
-title=sget('title')
-
-!! All done cracking the command line use the values in your program.
-print all,'x=',x,' y=',y,' z=',z
-print all,'i=',i,' j=',j,' k=',k
-print all,'l=',l,' m=',m,' n=',n
-print all,'title=',title
-
-!! The optional unnamed values on the command line are
-!! accumulated in the character array "UNNAMED" which was
-!! renamed to "FILENAMES" on the use statement
-if(size(filenames)>0)then
- print all,'files:'
-print'(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
-endif
+!!
+!! demo17 *
+!!
+!! Also demonstrates setting --help and --version text.
+!!
+!! demo17 --help
+!! demo17 --version
+!! demo17 --usage
+!!
+use M_CLI2,only:get_args
+use M_CLI2,only:sget,lget,iget,rget,dget,cget
+use M_CLI2,only:sgets,lgets,igets,rgets,dgets,cgets
+use M_CLI2,only:filenames=>unnamed
+implicit none
+type(character(len=*)),parameter::all='(*(g0))'
+type(integer)::indx
+
+!! argument values to set
+type(integer)::i,j,k
+type(real)::x,y,z
+type(character(len=:)),allocatable::title
+type(logical)::l,m,n
+type(character(len=:)),allocatable::fnames(:)
+
+print all,'demo17: using the unnamed parameters as filenames'
+print all,'example: demo17 -x 100 * '
+
+call parse()!! Define and parse command line
+!! Get argument values
+call get_args('x',x,'y',y,'z',z)
+call get_args('i',i,'j',j,'k',k)
+call get_args('l',l,'m',m,'n',n)
+title=sget('title')
+
+!! All done cracking the command line use the values in your program.
+print all,'x=',x,' y=',y,' z=',z
+print all,'i=',i,' j=',j,' k=',k
+print all,'l=',l,' m=',m,' n=',n
+print all,'title=',title
-fnames=sgets()! also gets all the unnamed arguments
-if(size(fnames)>0)then
- print all,'files:'
-print'(i6.6,1x,3a)',(indx,'[',fnames(indx),']',indx=1,size(fnames))
-endif
-
-contains
-subroutine parse()
-!! Put everything to do with command parsing here
-!!
-use M_CLI2,only:set_args,set_mode
-call set_mode([character(len=20)::'strict','ignorecase'])
-call set_args(&
-!! DEFINE COMMAND OPTIONS AND DEFAULT VALUES
-' &
- -i 1 -j 2 -k 3 &
- -l F -m F -n F &
- -x 1 -y 2 -z 3 &
- --title "my title" &
-!! ## HELP TEXT ##
-',[character(len=80)::&
-!12345678901234567890123456789012345678901234567890123456789012345678901234567890
-'NAME ',&
-' myprogram(1) - make all things possible ',&
-'SYNOPSIS ',&
-' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ',&
-' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ',&
-'DESCRIPTION ',&
-' myprogram(1) makes all things possible given stuff. ',&
-'OPTIONS ',&
-' -i,-j,-k some integer values ',&
-' -l,-m,-n some logical values ',&
-' -x,-y,-z some real values ',&
-' --title a string argument ',&
-' FILENAMES any additional strings ',&
-'EXAMPLE ',&
-' Typical usage: ',&
-' ',&
-' demo17 *.* ',&
-' ',&
-' ',&
-!! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ##
-''],[character(len=80)::&
-'@(#)PROGRAM: demo17 >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200115 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-''])
-
-end subroutine parse
-
-end program demo17
+!! The optional unnamed values on the command line are
+!! accumulated in the character array "UNNAMED" which was
+!! renamed to "FILENAMES" on the use statement
+if(allocated(filenames))then
+ if(size(filenames)>0)then
+ print all,'files:'
+print'(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
+endif
+ endif
+
+! alternate method, additionally can be used when desired result is numeric
+! by using igets(3f), rgets(3f), ... instead of sgets(3f).
+
+fnames=sgets()! also gets all the unnamed arguments
+if(size(fnames)>0)then
+ print all,'files:'
+print'(i6.6,1x,3a)',(indx,'[',fnames(indx),']',indx=1,size(fnames))
+endif
+
+contains
+subroutine parse()
+!! Put everything to do with command parsing here
+!!
+use M_CLI2,only:set_args,set_mode
+call set_mode([character(len=20)::'strict','ignorecase'])
+! a single call to set_args can define the options and their defaults, set help
+! text and version information, and crack command line.
+call set_args(&
+!! DEFINE COMMAND OPTIONS AND DEFAULT VALUES
+' &
+ -i 1 -j 2 -k 3 &
+ -l F -m F -n F &
+ -x 1 -y 2 -z 3 &
+ --title "my title" &
+!! ## HELP TEXT ##
+',[character(len=80)::&
+!12345678901234567890123456789012345678901234567890123456789012345678901234567890
+'NAME ',&
+' myprogram(1) - make all things possible ',&
+'SYNOPSIS ',&
+' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ',&
+' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ',&
+'DESCRIPTION ',&
+' myprogram(1) makes all things possible given stuff. ',&
+'OPTIONS ',&
+' -i,-j,-k some integer values ',&
+' -l,-m,-n some logical values ',&
+' -x,-y,-z some real values ',&
+' --title a string argument ',&
+' FILENAMES any additional strings ',&
+'EXAMPLE ',&
+' Typical usage: ',&
+' ',&
+' demo17 *.* ',&
+' ',&
+' ',&
+!! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ##
+''],[character(len=80)::&
+'@(#)PROGRAM: demo17 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200115 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+''])
+
+end subroutine parse
+
+end program demo17
@@ -321,7 +336,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo2.f90.html b/docs/fpm-ford/sourcefile/demo2.f90.html
index c1320475..26155b0e 100644
--- a/docs/fpm-ford/sourcefile/demo2.f90.html
+++ b/docs/fpm-ford/sourcefile/demo2.f90.html
@@ -90,7 +90,7 @@
demo2.f90
35 statements
+ title=" 1.0% of total for source files.">36 statements
@@ -219,76 +219,78 @@
Source Code
character(len=80)::titlelogical::l,l_
-call parse()!! DEFINE AND PARSE COMMAND LINE
+print*,'demo2: all parsing and **help** and **version** information in a contained procedure'
-!! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.
-write(*,*)x+y+z
-write(*,*)point*2
-write(*,*)title
-write(*,*)l,l_
-
-!! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE
-!! ACCUMULATED IN THE CHARACTER ARRAY "UNNAMED"
-if(size(unnamed)>0)then
- write(*,'(a)')'files:'
-write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
-endif
-
-contains
- subroutine parse()
-!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
-use M_CLI2,only:set_args,get_args
-use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
-character(len=:),allocatable::help_text(:),version_text(:)
-
-!! DEFINE COMMAND PROTOTYPE
-!! o All parameters must be listed with a default value
-!! o string values must be double-quoted
-!! o numeric lists must be comma-delimited. No spaces are allowed
-!! o long keynames must be all lowercase
-
-character(len=*),parameter::cmd='&
- & -x 1 -y 2 -z 3 &
- & --point -1,-2,-3 &
- & --title "my title" &
- & -l F -L F &
- & '
-
-help_text=[character(len=80)::&
-'NAME ',&
-' myprocedure(1) - make all things possible ',&
-'SYNOPSIS ',&
-' function myprocedure(stuff) ',&
-' class(*) :: stuff ',&
-'DESCRIPTION ',&
-' myprocedure(1) makes all things possible given STUFF ',&
-'OPTIONS ',&
-' STUFF things to do things to ',&
-'RETURNS ',&
-' MYPROCEDURE the answers you want ',&
-'EXAMPLE ',&
-'']
-
-version_text=[character(len=80)::&
-'@(#)PROGRAM: demo2 >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200115 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-'']
-
-call set_args(cmd,help_text,version_text)
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-call get_args_fixed_size('point',point)
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-
-end subroutine parse
+call parse()!! DEFINE AND PARSE COMMAND LINE
+
+!! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.
+write(*,*)x+y+z
+write(*,*)point*2
+write(*,*)title
+write(*,*)l,l_
+
+!! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE
+!! ACCUMULATED IN THE CHARACTER ARRAY "UNNAMED"
+if(size(unnamed)>0)then
+ write(*,'(a)')'files:'
+write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
+endif
+
+contains
+subroutine parse()
+!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
+use M_CLI2,only:set_args,get_args
+use M_CLI2,only:get_args_fixed_size,get_args_fixed_length
+character(len=:),allocatable::help_text(:),version_text(:)
+
+!! DEFINE COMMAND PROTOTYPE
+!! o All parameters must be listed with a default value
+!! o string values must be double-quoted
+!! o numeric lists must be comma-delimited. No spaces are allowed
+!! o long keynames must be all lowercase
+
+character(len=*),parameter::cmd='&
+ & -x 1 -y 2 -z 3 &
+ & --point -1,-2,-3 &
+ & --title "my title" &
+ & -l F -L F &
+ & '
+
+help_text=[character(len=80)::&
+'NAME ',&
+' myprocedure(1) - make all things possible ',&
+'SYNOPSIS ',&
+' function myprocedure(stuff) ',&
+' class(*) :: stuff ',&
+'DESCRIPTION ',&
+' myprocedure(1) makes all things possible given STUFF ',&
+'OPTIONS ',&
+' STUFF things to do things to ',&
+'RETURNS ',&
+' MYPROCEDURE the answers you want ',&
+'EXAMPLE ',&
+'']
+
+version_text=[character(len=80)::&
+'@(#)PROGRAM: demo2 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200115 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+'']
+
+call set_args(cmd,help_text,version_text)
+call get_args('x',x)
+call get_args('y',y)
+call get_args('z',z)
+call get_args_fixed_size('point',point)
+call get_args_fixed_length('title',title)
+call get_args('l',l)
+call get_args('L',l_)
-end program demo2
+end subroutine parse
+
+end program demo2
@@ -307,7 +309,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo3.f90.html b/docs/fpm-ford/sourcefile/demo3.f90.html
index dc25621b..65eeb7f7 100644
--- a/docs/fpm-ford/sourcefile/demo3.f90.html
+++ b/docs/fpm-ford/sourcefile/demo3.f90.html
@@ -90,7 +90,7 @@
demo3.f90
12 statements
+ title=" 0.4% of total for source files.">13 statements
@@ -215,12 +215,20 @@
Source Code
logical::lreal::sizecharacter(len=:),allocatable::title
-call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
-call get_args('x',x,'y',y,'l',l,'size',size)! all the non-allocatables
-call get_args('title',title)
-! Done. all variables set and of the right type
-write(*,'(*("[",g0,"]":,1x))')x,y,size,l,title
-end program demo3
+
+print*,'demo3: just the bare essentials'
+
+! define the command, set default values and read the command line
+call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
+
+! get the values
+call get_args('x',x,'y',y,'l',l,'size',size)! all the non-allocatables
+call get_args('title',title)! do allocatables one at a time
+
+! Done. All variables set and of the requested type
+write(*,'(*("[",g0,"]":,1x))')x,y,size,l,title
+
+end program demo3
@@ -239,7 +247,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo4.f90.html b/docs/fpm-ford/sourcefile/demo4.f90.html
index 129f8598..32d61f1c 100644
--- a/docs/fpm-ford/sourcefile/demo4.f90.html
+++ b/docs/fpm-ford/sourcefile/demo4.f90.html
@@ -90,7 +90,7 @@
demo4.f90
18 statements
+ title=" 0.5% of total for source files.">19 statements
@@ -219,47 +219,49 @@
Source Code
character(len=*),parameter::form='("(",g0,",",g0,"i)":,1x)'character(len=*),parameter::forms='(*("(",g0,",",g0,"i)":,",",1x))'
-! COMPLEX VALUES
-!
-! o parenthesis are optional and are ignored in complex values.
+print*,'demo4: COMPLEX argument example'
+
+! COMPLEX VALUES!
-! o base#value is acceptable for base 2 to 32 for whole numbers,
-! which is why "i" is not allowed as a suffix on imaginary values
-! (because some bases include "i" as a digit).
-!
-! o normally arrays are allocatable. if a fixed size array is used
-! call get_args_fixed_size(3f) and all the values must be
-! specified. This is useful when you have something that requires
-! a specific number of values. Perhaps a point in space must always
-! have three values, for example.
-!
-! o default delimiters are whitespace, comma and colon. Note that
-! whitespace delimiters should not be used in the definition,
-! but are OK on command input if the entire parameter value is
-! quoted. Using space delimiters in the prototype definition is
-! not supported (but works) and requires that the value be quoted
-! on input in common shells. Adjacent delimiters are treated as
-! a single delimiter.
-!
-call set_args('-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444')
-call get_args('x',x)
-call get_args('y',y)
-call get_args('z',z)
-call get_args_fixed_size('three',three)
-call get_args('aarr',aarr)
-write(*,form)x,y,z,x+y+z
-write(*,forms)three
-write(*,forms)aarr
-end program demo4
-!
-! expected output:
+! o parenthesis are optional and are ignored in complex values.
+!
+! o base#value is acceptable for base 2 to 32 for whole numbers,
+! which is why "i" is not allowed as a suffix on imaginary values
+! (because some bases include "i" as a digit).
+!
+! o normally arrays are allocatable. if a fixed size array is used
+! call get_args_fixed_size(3f) and all the values must be
+! specified. This is useful when you have something that requires
+! a specific number of values. Perhaps a point in space must always
+! have three values, for example.
+!
+! o default delimiters are whitespace, comma and colon. Note that
+! whitespace delimiters should not be used in the definition,
+! but are OK on command input if the entire parameter value is
+! quoted. Using space delimiters in the prototype definition is
+! not supported (but works) and requires that the value be quoted
+! on input in common shells. Adjacent delimiters are treated as
+! a single delimiter.
+!
+call set_args('-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444')
+call get_args('x',x)
+call get_args('y',y)
+call get_args('z',z)
+call get_args_fixed_size('three',three)
+call get_args('aarr',aarr)
+write(*,form)x,y,z,x+y+z
+write(*,forms)three
+write(*,forms)aarr
+end program demo4!
-! (1.00000000,2.00000000i)
-! (10.0000000,20.0000000i)
-! (7.00000000,-171.000000i)
-! (18.0000000,-149.000000i)
-! (1.00000000,2.00000000i), (3.00000000,4.00000000i), (5.00000000,6.00000000i)
-! (111.000000,222.000000i), (333.000000,444.000000i)
+! expected output:
+!
+! (1.00000000,2.00000000i)
+! (10.0000000,20.0000000i)
+! (7.00000000,-171.000000i)
+! (18.0000000,-149.000000i)
+! (1.00000000,2.00000000i), (3.00000000,4.00000000i), (5.00000000,6.00000000i)
+! (111.000000,222.000000i), (333.000000,444.000000i)
@@ -278,7 +280,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo5.f90.html b/docs/fpm-ford/sourcefile/demo5.f90.html
index 78fb520c..a3d2f31c 100644
--- a/docs/fpm-ford/sourcefile/demo5.f90.html
+++ b/docs/fpm-ford/sourcefile/demo5.f90.html
@@ -90,7 +90,7 @@
demo5.f90
44 statements
+ title=" 1.3% of total for source files.">45 statements
@@ -216,68 +216,72 @@
Source Code
implicit nonecharacter(len=*),parameter::fmt='(*("[",g0,"]":,1x))'
-call set_args(' &
- & --alloc_len_scalar " " --fx_len_scalar " " &
- & --alloc_array "A,B,C" &
- & --fx_size_fx_len "A,B,C" &
- & --fx_len_alloc_array "A,B,C" &
- & ')
-
-block
-! you just need get_args(3f) for general scalars or arrays
-! variable length scalar
-character(len=:),allocatable::alloc_len_scalar
-! variable array size and variable length
-character(len=:),allocatable::alloc_array(:)
-call get_args('alloc_len_scalar',alloc_len_scalar)
-write(*,fmt)'allocatable length scalar=',alloc_len_scalar,&
-&len(alloc_len_scalar)
-
-call get_args('alloc_array',alloc_array)
-write(*,fmt)'allocatable array= ',alloc_array
-endblock
+
+print*,'demo5: CHARACTER argument examples'
+
+call set_args(' &
+ & --alloc_len_scalar " " &
+ & --fx_len_scalar " " &
+ & --alloc_array "A,B,C" &
+ & --fx_size_fx_len "A,B,C" &
+ & --fx_len_alloc_array "A,B,C" &
+ & ')
+
+block
+! you just need get_args(3f) for general scalars or arrays
+! variable length scalar
+character(len=:),allocatable::alloc_len_scalar
+! variable array size and variable length
+character(len=:),allocatable::alloc_array(:)
+call get_args('alloc_len_scalar',alloc_len_scalar)
+write(*,fmt)'allocatable length scalar=',alloc_len_scalar,&
+&len(alloc_len_scalar)
-! less commonly, if length or size is fixed, use a special function
-
-block
-character(len=19),allocatable::fx_len_alloc_array(:)
-call get_args_fixed_length('fx_len_alloc_array',fx_len_alloc_array)
-write(*,fmt)'fixed length allocatable array=',fx_len_alloc_array
-endblock
-
- block
-character(len=19)::fx_len_scalar
-call get_args_fixed_length('fx_len_scalar',fx_len_scalar)
-write(*,fmt)'fixed length scalar= ',fx_len_scalar
-endblock
-
- block
-character(len=19)::fx_size_fx_len(3)
-call get_args_fixed_size('fx_size_fx_len',fx_size_fx_len)
-write(*,fmt)'fixed size fixed length= ',fx_size_fx_len
-endblock
-
- block
-! or (recommended) set to an allocatable array and check size and
-! length returned
-character(len=:),allocatable::a! variable length scalar
-character(len=:),allocatable::arr(:)! variable array size and variable length
-call get_args('fx_size_fx_len',arr)
-! or
-arr=sgets('fx_size_fx_len')
-if(size(arr)/=3)write(*,*)'not right size'
-if(len(arr)>19)write(*,*)'longer than wanted'
-
-call get_args('fx_len_scalar',a)
-!or
-a=sget('fx_len_scalar')
-if(len(a)>19)write(*,*)'too long'
-write(*,*)a,len(a)
-write(*,*)arr,len(arr),size(arr)
-
-endblock
-
-end program demo5
+call get_args('alloc_array',alloc_array)
+write(*,fmt)'allocatable array= ',alloc_array
+endblock
+
+! less commonly, if length or size is fixed, use a special function
+
+block
+character(len=19),allocatable::fx_len_alloc_array(:)
+call get_args_fixed_length('fx_len_alloc_array',fx_len_alloc_array)
+write(*,fmt)'fixed length allocatable array=',fx_len_alloc_array
+endblock
+
+ block
+character(len=19)::fx_len_scalar
+call get_args_fixed_length('fx_len_scalar',fx_len_scalar)
+write(*,fmt)'fixed length scalar= ',fx_len_scalar
+endblock
+
+ block
+character(len=19)::fx_size_fx_len(3)
+call get_args_fixed_size('fx_size_fx_len',fx_size_fx_len)
+write(*,fmt)'fixed size fixed length= ',fx_size_fx_len
+endblock
+
+ block
+! or (recommended) set to an allocatable array and check size and
+! length returned
+character(len=:),allocatable::a! variable length scalar
+character(len=:),allocatable::arr(:)! variable array size and variable length
+call get_args('fx_size_fx_len',arr)
+! or
+arr=sgets('fx_size_fx_len')
+if(size(arr)/=3)write(*,*)'not right size'
+if(len(arr)>19)write(*,*)'longer than wanted'
+
+call get_args('fx_len_scalar',a)
+!or
+a=sget('fx_len_scalar')
+if(len(a)>19)write(*,*)'too long'
+write(*,*)a,len(a)
+write(*,*)arr,len(arr),size(arr)
+
+endblock
+
+end program demo5
@@ -296,7 +300,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo6.f90.html b/docs/fpm-ford/sourcefile/demo6.f90.html
index 38f04d61..bd7f1870 100644
--- a/docs/fpm-ford/sourcefile/demo6.f90.html
+++ b/docs/fpm-ford/sourcefile/demo6.f90.html
@@ -90,7 +90,7 @@
demo6.f90
47 statements
+ title=" 1.4% of total for source files.">48 statements
@@ -228,79 +228,81 @@
Source Code
character(len=80)::title,testnamelogical::l,l_
-version_text=[character(len=80)::&
-'@(#)PROGRAM: demo6 >',&
-'@(#)DESCRIPTION: My demo program >',&
-'@(#)VERSION: 1.0 20200715 >',&
-'@(#)AUTHOR: me, myself, and I>',&
-'@(#)LICENSE: Public Domain >',&
-'']
-CLI_RESPONSE_FILE=.true.
-! find the subcommand name by looking for first word on command
-! not starting with dash
-name=get_subcommand()
-
-! define commands and parse command line and set help text and process command
-select case(name)
-
-case('run')
-help_text=[character(len=80)::&
-' ',&
-' Help for subcommand "run" ',&
+print*,'demo6: creating subcommands'
+
+version_text=[character(len=80)::&
+'@(#)PROGRAM: demo6 >',&
+'@(#)DESCRIPTION: My demo program >',&
+'@(#)VERSION: 1.0 20200715 >',&
+'@(#)AUTHOR: me, myself, and I>',&
+'@(#)LICENSE: Public Domain >',&
+'']
+CLI_RESPONSE_FILE=.true.
+! find the subcommand name by looking for first word on command
+! not starting with dash
+name=get_subcommand()
+
+! define commands and parse command line and set help text and process command
+select case(name)
+
+case('run')
+help_text=[character(len=80)::&' ',&
-'']
-call set_args('-x 1 -y 2 -z 3 --title "my title" -l F -L F',help_text,version_text)
-! example using convenience functions to retrieve values and pass them
-! to a routine
-call my_run(rget('x'),rget('y'),rget('z'),sget('title'),lget('l'),lget('L'))
-
-case('test')
-help_text=[character(len=80)::&
-' ',&
-' Help for subcommand "test" ',&
+' Help for subcommand "run" ',&
+' ',&
+'']
+call set_args('-x 1 -y 2 -z 3 --title "my title" -l F -L F',help_text,version_text)
+! example using convenience functions to retrieve values and pass them
+! to a routine
+call my_run(rget('x'),rget('y'),rget('z'),sget('title'),lget('l'),lget('L'))
+
+case('test')
+help_text=[character(len=80)::&' ',&
-'']
-call set_args('--title "my title" -l F -L F --testname "Test"',help_text,version_text)
-! use get_args(3f) to extract values and use them
-call get_args_fixed_length('title',title)
-call get_args('l',l)
-call get_args('L',l_)
-call get_args_fixed_length('testname',testname)
-! all done cracking the command line. use the values in your program.
-write(*,*)'command was ',name
-write(*,*)'title .... ',trim(title)
-write(*,*)'l,l_ ..... ',l,l_
-write(*,*)'testname . ',trim(testname)
-
-case('')
-! general help for "demo6 --help"
-help_text=[character(len=80)::&
-' General help describing the ',&
-' program. ',&
-'']
-call set_args(' ',help_text,version_text)! process help and version
-
-case default
-call set_args(' ',help_text,version_text)! process help and version
-write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']'
-
-end select
+' Help for subcommand "test" ',&
+' ',&
+'']
+call set_args('--title "my title" -l F -L F --testname "Test"',help_text,version_text)
+! use get_args(3f) to extract values and use them
+call get_args_fixed_length('title',title)
+call get_args('l',l)
+call get_args('L',l_)
+call get_args_fixed_length('testname',testname)
+! all done cracking the command line. use the values in your program.
+write(*,*)'command was ',name
+write(*,*)'title .... ',trim(title)
+write(*,*)'l,l_ ..... ',l,l_
+write(*,*)'testname . ',trim(testname)
+
+case('')
+! general help for "demo6 --help"
+help_text=[character(len=80)::&
+' General help describing the ',&
+' program. ',&
+'']
+call set_args(' ',help_text,version_text)! process help and version
+
+case default
+call set_args(' ',help_text,version_text)! process help and version
+write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']'
-contains
+end select
-subroutine my_run(x,y,z,title,l,l_)
-! nothing about commandline parsing here!
-real,intent(in)::x,y,z
-character(len=*),intent(in)::title
-logical,intent(in)::l
-logical,intent(in)::l_
-write(*,*)'MY_RUN'
-write(*,*)'x,y,z .....',x,y,z
-write(*,*)'title .... ',title
-write(*,*)'l,l_ ..... ',l,l_
-end subroutine my_run
-
-end program demo6
+contains
+
+subroutine my_run(x,y,z,title,l,l_)
+! nothing about commandline parsing here!
+real,intent(in)::x,y,z
+character(len=*),intent(in)::title
+logical,intent(in)::l
+logical,intent(in)::l_
+write(*,*)'MY_RUN'
+write(*,*)'x,y,z .....',x,y,z
+write(*,*)'title .... ',title
+write(*,*)'l,l_ ..... ',l,l_
+end subroutine my_run
+
+end program demo6
@@ -319,7 +321,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo7.f90.html b/docs/fpm-ford/sourcefile/demo7.f90.html
index fa072262..80129d0f 100644
--- a/docs/fpm-ford/sourcefile/demo7.f90.html
+++ b/docs/fpm-ford/sourcefile/demo7.f90.html
@@ -90,7 +90,7 @@
demo7.f90
30 statements
+ title=" 0.9% of total for source files.">31 statements
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo8.f90.html b/docs/fpm-ford/sourcefile/demo8.f90.html
index 63ddf23e..21b3c852 100644
--- a/docs/fpm-ford/sourcefile/demo8.f90.html
+++ b/docs/fpm-ford/sourcefile/demo8.f90.html
@@ -90,7 +90,7 @@
demo8.f90
12 statements
+ title=" 0.4% of total for source files.">13 statements
@@ -216,16 +216,22 @@
Source Code
real::sizecharacter(len=80)::titlecharacter(len=*),parameter::pairs='(1("[",g0,"=",g0,"]":,1x))'
-! DEFINE COMMAND AND PARSE COMMAND LINE
-! set all values, double-quote strings
-call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
-! GET THE VALUES
-! only fixed scalar values (including only character variables that
-! are fixed length) may be combined in one GET_ARGS(3f) call
-call get_args('x',x,'y',y,'l',l,'size',size,'title',title)
-! USE THE VALUES
-write(*,fmt=pairs)'X',x,'Y',y,'size',size,'L',l,'TITLE',title
-end program demo8
+
+print*,'demo8: Sometimes you can put multiple values on getargs(3f)'
+
+! DEFINE COMMAND AND PARSE COMMAND LINE
+! set all values, double-quote strings
+call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
+
+! GET THE VALUES
+! only fixed scalar values (including only character variables that
+! are fixed length) may be combined in one GET_ARGS(3f) call
+call get_args('x',x,'y',y,'l',l,'size',size,'title',title)
+
+! USE THE VALUES
+write(*,fmt=pairs)'X',x,'Y',y,'size',size,'L',l,'TITLE',title
+
+end program demo8
@@ -244,7 +250,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo9.f90.html b/docs/fpm-ford/sourcefile/demo9.f90.html
index d8f59eeb..27d24ae5 100644
--- a/docs/fpm-ford/sourcefile/demo9.f90.html
+++ b/docs/fpm-ford/sourcefile/demo9.f90.html
@@ -90,7 +90,7 @@
demo9.f90
12 statements
+ title=" 0.4% of total for source files.">13 statements
@@ -210,29 +210,32 @@
Source Code
program demo9!> @(#) long and short names using --LONGNAME:SHORTNAME!!
-!! When all keys have a long and short name "strict mode" is invoked where
-!! "-" is required for short names; and Boolean values may be bundled
-!! together. For example:
+!! When all keys have a long and short name and "strict mode" is invoked
+!! where "-" is required for short names and "--" for long names Boolean
+!! values may be bundled together. For example:!!!! demo9 -XYZ!!
-use M_CLI2,only:set_args,sget,rget,lget
+use M_CLI2,only:set_args,sget,rget,lget,set_modeimplicit nonecharacter(len=*),parameter::all='(*(g0))'
-call set_args(' &
- & --length:l 10 &
- & --height:h 12.45 &
- & --switchX:X F &
- & --switchY:Y F &
- & --switchZ:Z F &
- & --title:T "my title"')
-print all,'--length or -l .... ',rget('length')
-print all,'--height or -h .... ',rget('height')
-print all,'--switchX or -X ... ',lget('switchX')
-print all,'--switchY or -Y ... ',lget('switchY')
-print all,'--switchZ or -Z ... ',lget('switchZ')
-print all,'--title or -T ..... ',sget('title')
-end program demo9
+
+print*,'demo9: long and short names using --LONGNAME:SHORTNAME'
+!call set_mode('strict')
+call set_args(' &
+ & --length:l 10 &
+ & --height:h 12.45 &
+ & --switchX:X F &
+ & --switchY:Y F &
+ & --switchZ:Z F &
+ & --title:T "my title"')
+print all,'--length or -l .... ',rget('length')
+print all,'--height or -h .... ',rget('height')
+print all,'--switchX or -X ... ',lget('switchX')
+print all,'--switchY or -Y ... ',lget('switchY')
+print all,'--switchZ or -Z ... ',lget('switchZ')
+print all,'--title or -T ..... ',sget('title')
+end program demo9
@@ -251,7 +254,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_get_args.f90.html b/docs/fpm-ford/sourcefile/demo_get_args.f90.html
index d3503a94..8106f6be 100644
--- a/docs/fpm-ford/sourcefile/demo_get_args.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_get_args.f90.html
@@ -90,7 +90,7 @@
demo_get_args.f90
23 statements
+ title=" 0.6% of total for source files.">21 statements
@@ -211,40 +211,38 @@
Source Code
use M_CLI2,only:filenames=>unnamed,set_args,get_argsimplicit noneinteger::i
-! DEFINE ARGS
+! Define ARGSreal::x,y,zreal,allocatable::p(:)character(len=:),allocatable::titlelogical::l,lbig
-! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-! o only quote strings and use double-quotes
-! o set all logical values to F or T.
-call set_args(' &
- & -x 1 -y 2 -z 3 &
- & -p -1,-2,-3 &
+! Define and parse (to set initial values) command line
+! o only quote strings and use double-quotes
+! o set all logical values to F or T.
+call set_args(' &
+ & -x 1 -y 2 -z 3 &
+ & -p -1,-2,-3 & & --title "my title" &
- & -l F -L F &
- & --label " " &
+ & -l F -L F &
+ & --label " " & & ')
-! ASSIGN VALUES TO ELEMENTS
-! SCALARS
-call get_args('x',x,'y',y,'z',z)
-call get_args('l',l)
-call get_args('L',lbig)
-! ALLOCATABLE STRING
-call get_args('title',title)
-! NON-ALLOCATABLE ARRAYS
-call get_args('p',p)
-! USE VALUES
-write(*,'(1x,g0,"=",g0)')'x',x,'y',y,'z',z
-write(*,*)'p=',p
-write(*,*)'title=',title
-write(*,*)'l=',l
-write(*,*)'L=',lbig
-if(size(filenames)>0)then
- write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
-endif
- end program demo_get_args
+! Assign values to elements
+! Scalars
+call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+! Allocatable string
+call get_args('title',title)
+! Allocatable arrays
+call get_args('p',p)
+! Use values
+write(*,'(1x,g0,"=",g0)')'x',x,'y',y,'z',z
+write(*,*)'p=',p
+write(*,*)'title=',title
+write(*,*)'l=',l
+write(*,*)'L=',lbig
+if(size(filenames)>0)then
+ write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
+endif
+ end program demo_get_args
@@ -263,7 +261,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_get_args_fixed_length.f90.html b/docs/fpm-ford/sourcefile/demo_get_args_fixed_length.f90.html
index ee86bbb3..a11b5bbc 100644
--- a/docs/fpm-ford/sourcefile/demo_get_args_fixed_length.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_get_args_fixed_length.f90.html
@@ -210,16 +210,17 @@
Source Code
program demo_get_args_fixed_lengthuse M_CLI2,only:set_args,get_args_fixed_lengthimplicit none
-! DEFINE ARGS
-character(len=80)::title
-call set_args(' &
- & --title "my title" &
- & ')
-! ASSIGN VALUES TO ELEMENTS
-call get_args_fixed_length('title',title)
-! USE VALUES
-write(*,*)'title=',title
-end program demo_get_args_fixed_length
+
+! Define args
+character(len=80)::title
+! Parse command line
+call set_args(' --title "my title" ')
+! Assign values to variables
+call get_args_fixed_length('title',title)
+! Use values
+write(*,*)'title=',title
+
+end program demo_get_args_fixed_length
@@ -238,7 +239,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_get_args_fixed_size.f90.html b/docs/fpm-ford/sourcefile/demo_get_args_fixed_size.f90.html
index 088b73d5..0c2e82c9 100644
--- a/docs/fpm-ford/sourcefile/demo_get_args_fixed_size.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_get_args_fixed_size.f90.html
@@ -263,7 +263,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_get_subcommand.f90.html b/docs/fpm-ford/sourcefile/demo_get_subcommand.f90.html
index db43bc71..0a371c04 100644
--- a/docs/fpm-ford/sourcefile/demo_get_subcommand.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_get_subcommand.f90.html
@@ -214,8 +214,8 @@
Source Code
!x! You can call this program which has two subcommands (run, test),!x! like this:!x! demo_get_subcommand --help
-!x! demo_get_subcommand run -x -y -z -title -l -L
-!x! demo_get_subcommand test -title -l -L -testname
+!x! demo_get_subcommand run -x -y -z --title -l -L
+!x! demo_get_subcommand test --title -l -L --testname!x! demo_get_subcommand run --helpimplicit none!x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
@@ -252,8 +252,8 @@
Source Code
! general help for "demo_get_subcommand --help"help_text=[character(len=80)::&' allowed subcommands are ',&
-' * run -l -L -title -x -y -z ',&
-' * test -l -L -title ',&
+' * run -l -L --title -x -y -z ',&
+' * test -l -L --title ',&'']! find the subcommand name by looking for first word on command! not starting with dash
@@ -318,7 +318,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_set_mode.f90.html b/docs/fpm-ford/sourcefile/demo_set_mode.f90.html
index d80cf696..1a87e881 100644
--- a/docs/fpm-ford/sourcefile/demo_set_mode.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_set_mode.f90.html
@@ -90,7 +90,7 @@
demo_set_mode.f90
16 statements
+ title=" 0.5% of total for source files.">16 statements
@@ -215,16 +215,16 @@
Source Code
! enable use of response filescall set_mode('response_file')!
-! Any dash in a keyname is treated as an underscore
+! Any dash in a keyword is treated as an underscorecall set_mode('underdash')!
-! The case of long keynames are ignored.
+! The case of long keywords are ignored.! Values and short names remain case-sensitivecall set_mode('ignorecase')!! short single-character boolean keys may be bundled! but it is required that a single dash is used for
-! short keys and a double dash for long keynames.
+! short keys and a double dash for long keywords.call set_mode('strict')!call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
@@ -254,7 +254,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/demo_specified.f90.html b/docs/fpm-ford/sourcefile/demo_specified.f90.html
index 4c09cdf2..9d35ba16 100644
--- a/docs/fpm-ford/sourcefile/demo_specified.f90.html
+++ b/docs/fpm-ford/sourcefile/demo_specified.f90.html
@@ -90,7 +90,7 @@
demo_specified.f90
26 statements
+ title=" 1.4% of total for source files.">50 statements
@@ -208,48 +208,82 @@
Source Code
program demo_specified
-use M_CLI2,only:set_args,get_args,specified
-implicit none
-! DEFINE ARGS
-integer::flag
-integer,allocatable::ints(:)
-real,allocatable::two_names(:)
-
-! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED
-! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM
-call set_args('&
- & --flag 1 -f 1 &
- & --ints 1,2,3 -i 1,2,3 &
- & --two_names 11.3 -T 11.3')
-
-! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME
-call get_args('flag',flag)
-if(specified('f'))call get_args('f',flag)
-call get_args('ints',ints)
-if(specified('i'))call get_args('i',ints)
-call get_args('two_names',two_names)
-if(specified('T'))call get_args('T',two_names)
-
-! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE
-! ANY(3f) and ALL(3f)
-write(*,*)specified(['two_names','T '])
-write(*,*)'ANY:',any(specified(['two_names','T ']))
-write(*,*)'ALL:',all(specified(['two_names','T ']))
-
-! FOR MUTUALLY EXCLUSIVE
-if(all(specified(['two_names','T '])))then
- write(*,*)'You specified both names -T and -two_names'
-endif
-
-! FOR REQUIRED PARAMETER
-if(.not.any(specified(['two_names','T '])))then
- write(*,*)'You must specify -T or -two_names'
-endif
-! USE VALUES
-write(*,*)'flag=',flag
-write(*,*)'ints=',ints
-write(*,*)'two_names=',two_names
-end program demo_specified
+use,intrinsic::iso_fortran_env,only:&
+&stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT
+use M_CLI2,only:set_args,igets,rgets,specified,sget,lget
+implicit none
+
+! Define args
+integer,allocatable::ints(:)
+real,allocatable::floats(:)
+logical::flag
+character(len=:),allocatable::color
+character(len=:),allocatable::list(:)
+integer::i
+
+call set_args('&
+ & --color:c "red" &
+ & --flag:f F &
+ & --ints:i 1,10,11 &
+ & --floats:T 12.3, 4.56 &
+ & ')
+ints=igets('ints')
+floats=rgets('floats')
+flag=lget('flag')
+color=sget('color')
+
+write(*,*)'color=',color
+write(*,*)'flag=',flag
+write(*,*)'ints=',ints
+write(*,*)'floats=',floats
+
+write(*,*)'was -flag specified?',specified('flag')
+
+! elemental
+write(*,*)specified(['floats','ints '])
+
+! If you want to know if groups of parameters were specified use
+! ANY(3f) and ALL(3f)
+write(*,*)'ANY:',any(specified(['floats','ints ']))
+write(*,*)'ALL:',all(specified(['floats','ints ']))
+
+! For mutually exclusive
+if(all(specified(['floats','ints '])))then
+ write(*,*)'You specified both names --ints and --floats'
+endif
+
+! For required parameter
+if(.not.any(specified(['floats','ints '])))then
+ write(*,*)'You must specify --ints or --floats'
+endif
+
+! check if all values are in range from 10 to 30 and even
+write(*,*)'are all numbers good?',all([ints>=10,ints<=30,(ints/2)*2==ints])
+
+! perhaps you want to check one value at a time
+do i=1,size(ints)
+write(*,*)ints(i),[ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]
+if(all([ints(i)>=10,ints(i)<=30,(ints(i)/2)*2==ints(i)]))then
+ write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+else
+ write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+endif
+ enddo
+
+list=[character(len=10)::'red','white','blue']
+if(any(color==list))then
+ write(*,*)color,'matches a value in the list'
+else
+ write(*,*)color,'not in the list'
+endif
+
+ if(size(ints).eq.3)then
+ write(*,*)'ints(:) has expected number of values'
+else
+ write(*,*)'ints(:) does not have expected number of values'
+endif
+
+ end program demo_specified
@@ -268,7 +302,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/hello.f90.html b/docs/fpm-ford/sourcefile/hello.f90.html
index 4fcecd56..1d319cf4 100644
--- a/docs/fpm-ford/sourcefile/hello.f90.html
+++ b/docs/fpm-ford/sourcefile/hello.f90.html
@@ -240,7 +240,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/m_cli2.f90.html b/docs/fpm-ford/sourcefile/m_cli2.f90.html
index e8d40cbe..9d3f1ada 100644
--- a/docs/fpm-ford/sourcefile/m_cli2.f90.html
+++ b/docs/fpm-ford/sourcefile/m_cli2.f90.html
@@ -90,7 +90,7 @@
M_CLI2.F90
3079 statements
+ title="75.8% of total for source files.">2637 statements
!!!! Available procedures and variables:!!
-!! use M_CLI2, only : set_args, get_args, specified, set_mode
-!! use M_CLI2, only : unnamed, remaining, args
-!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
-!! ! convenience functions
-!! use M_CLI2, only : dget, iget, lget, rget, sget, cget
-!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
-!!
-!!##DESCRIPTION
-!! Allow for command line parsing much like standard Unix command line
-!! parsing using a simple prototype.
-!!
-!! Typically one call to SET_ARGS(3f) is made to define the command
-!! arguments, set default values and parse the command line. Then a call
-!! is made to the convenience commands based on GET_ARGS(3f) for each
-!! command keyword to obtain the argument values.
-!!
-!! The documentation for SET_ARGS(3f) and GET_ARGS(3f) provides further
-!! details.
-!!
-!!##EXAMPLE
-!!
-!!
-!! Sample typical minimal usage
-!!
-!! program minimal
-!! use M_CLI2, only : set_args, lget, rget, filenames=>unnamed
-!! implicit none
-!! real :: x, y
-!! integer :: i
-!! call set_args(' -y 0.0 -x 0.0 --debug F')
-!! x=rget('x')
-!! y=rget('y')
-!! if(lget('debug'))then
-!! write(*,*)'X=',x
-!! write(*,*)'Y=',y
-!! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y)
-!! else
-!! write(*,*)atan2(x=x,y=y)
-!! endif
-!! if(size(filenames) > 0)then
-!! write(*,'(g0)')'filenames:'
-!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
-!! endif
-!! end program minimal
-!!
-!! Sample program using get_args() and variants
-!!
-!! program demo_M_CLI2
-!! use M_CLI2, only : set_args, get_args
-!! use M_CLI2, only : filenames=>unnamed
-!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
-!! implicit none
-!! integer :: i
-!! integer,parameter :: dp=kind(0.0d0)
-!! !
-!! ! DEFINE ARGS
-!! real :: x, y, z
-!! real(kind=dp),allocatable :: point(:)
-!! logical :: l, lbig
-!! logical,allocatable :: logicals(:)
-!! character(len=:),allocatable :: title ! VARIABLE LENGTH
-!! character(len=40) :: label ! FIXED LENGTH
-!! real :: p(3) ! FIXED SIZE
-!! logical :: logi(3) ! FIXED SIZE
-!! !
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o set a value for all keywords.
-!! ! o double-quote strings
-!! ! o set all logical values to F or T.
-!! ! o value delimiter is comma, colon, or space
-!! call set_args(' &
-!! & -x 1 -y 2 -z 3 &
-!! & -p -1 -2 -3 &
-!! & --point 11.11, 22.22, 33.33e0 &
-!! & --title "my title" -l F -L F &
-!! & --logicals F F F F F &
-!! & --logi F T F &
-!! & --label " " &
-!! ! note space between quotes is required
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args('x',x) ! SCALARS
-!! call get_args('y',y)
-!! call get_args('z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! call get_args('title',title) ! ALLOCATABLE STRING
-!! call get_args('point',point) ! ALLOCATABLE ARRAYS
-!! call get_args('logicals',logicals)
-!! !
-!! ! for NON-ALLOCATABLE VARIABLES
-!!
-!! ! for non-allocatable string
-!! call get_args_fixed_length('label',label)
-!!
-!! ! for non-allocatable arrays
-!! call get_args_fixed_size('p',p)
-!! call get_args_fixed_size('logi',logi)
-!! !
-!! ! USE VALUES
-!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z
-!! write(*,*)'p=',p
-!! write(*,*)'point=',point
-!! write(*,*)'title=',title
-!! write(*,*)'label=',label
-!! write(*,*)'l=',l
-!! write(*,*)'L=',lbig
-!! write(*,*)'logicals=',logicals
-!! write(*,*)'logi=',logi
-!! !
-!! ! unnamed strings
-!! !
-!! if(size(filenames) > 0)then
-!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
-!! endif
-!! !
-!! end program demo_M_CLI2
+!! ! basic procedures
+!! use M_CLI2, only : set_args, get_args, specified, set_mode
+!! ! convenience functions
+!! use M_CLI2, only : dget, iget, lget, rget, sget, cget
+!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
+!! ! variables
+!! use M_CLI2, only : unnamed, remaining, args
+!! ! working with non-allocatable strings and arrays
+!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
+!! ! special function for creating subcommands
+!! use M_CLI2, only : get_subcommand(3f)
+!!
+!!##DESCRIPTION
+!! The M_CLI2 module cracks a Unix-style command line.
+!!
+!! Typically one call to SET_ARGS(3f) is made to define the command
+!! arguments, set default values and parse the command line. Then a call
+!! is made to the convenience procedures or GET_ARGS(3f) proper for each
+!! command keyword to obtain the argument values.
+!!
+!! Detailed descriptions of each procedure and example programs are
+!! included.
+!!
+!!##EXAMPLE
+!!
+!!
+!! Sample minimal program which may be called in various ways:
+!!
+!! mimimal -x 100.3 -y 3.0e4
+!! mimimal --xvalue=300 --debug
+!! mimimal --yvalue 400
+!! mimimal -x 10 file1 file2 file3
+!!
+!! Program example:
+!!
+!! program minimal
+!! use M_CLI2, only : set_args, lget, rget, sgets
+!! implicit none
+!! real :: x, y
+!! integer :: i
+!! character(len=:),allocatable :: filenames(:)
+!! ! define and crack command line
+!! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F')
+!! ! get values
+!! x=rget('xvalue')
+!! y=rget('yvalue')
+!! if(lget('debug'))then
+!! write(*,*)'X=',x
+!! write(*,*)'Y=',y
+!! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y)
+!! else
+!! write(*,*)atan2(x=x,y=y)
+!! endif
+!! filenames=sgets() ! sget with no name gets "unnamed" values
+!! if(size(filenames) > 0)then
+!! write(*,'(g0)')'filenames:'
+!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
+!! endif
+!! end program minimal
+!!
+!! Sample program using get_args() and variants
+!!
+!! program demo_M_CLI2
+!! use M_CLI2, only : set_args, get_args
+!! use M_CLI2, only : filenames=>unnamed
+!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
+!! implicit none
+!! integer :: i
+!! integer,parameter :: dp=kind(0.0d0)
+!! !
+!! ! Define ARGS
+!! real :: x, y, z
+!! logical :: l, lbig
+!! character(len=40) :: label ! FIXED LENGTH
+!! real(kind=dp),allocatable :: point(:)
+!! logical,allocatable :: logicals(:)
+!! character(len=:),allocatable :: title ! VARIABLE LENGTH
+!! real :: p(3) ! FIXED SIZE
+!! logical :: logi(3) ! FIXED SIZE
+!! !
+!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+!! ! o set a value for all keywords.
+!! ! o double-quote strings, strings must be at least one space
+!! ! because adjacent double-quotes designate a double-quote
+!! ! in the value.
+!! ! o set all logical values to F
+!! ! o numeric values support an "e" or "E" exponent
+!! ! o for lists delimit with a comma, colon, or space
+!! call set_args(' &
+!! & -x 1 -y 2 -z 3 &
+!! & -p -1 -2 -3 &
+!! & --point 11.11, 22.22, 33.33e0 &
+!! & --title "my title" -l F -L F &
+!! & --logicals F F F F F &
+!! & --logi F T F &
+!! & --label " " &
+!! ! note space between quotes is required
+!! & ')
+!! ! Assign values to elements using G_ARGS(3f).
+!! ! non-allocatable scalars can be done up to twenty per call
+!! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig)
+!! ! As a convenience multiple pairs of keywords and variables may be
+!! ! specified if and only if all the values are scalars and the CHARACTER
+!! ! variables are fixed-length or pre-allocated.
+!! !
+!! ! After SET_ARGS(3f) has parsed the command line
+!! ! GET_ARGS(3f) retrieves the value of keywords accept for
+!! ! two special cases. For fixed-length CHARACTER variables
+!! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! ! GET_ARGS_FIXED_SIZE(3f).
+!! !
+!! ! allocatables should be done one at a time
+!! call get_args('title',title) ! allocatable string
+!! call get_args('point',point) ! allocatable arrays
+!! call get_args('logicals',logicals)
+!! !
+!! ! less commonly ...!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-module M_CLI2
-use,intrinsic::iso_fortran_env,only:stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT,warn=>OUTPUT_UNIT
-
-! copied to M_CLI2 for a stand-alone version
-!use M_strings, only : upper, lower, quote, replace_str=>replace, unquote, split, string_to_value, atleast
-!use M_list, only : insert, locate, remove, replace
-!use M_args, only : longest_command_argument
-!use M_journal, only : journal
-
-implicit none
-integer,parameter,private::dp=kind(0.0d0)
-integer,parameter,private::sp=kind(0.0)
-private
-!===================================================================================================================================
-character(len=*),parameter::gen='(*(g0))'
-character(len=:),allocatable,public::unnamed(:)
-character(len=:),allocatable,public::args(:)
-character(len=:),allocatable,public::remaining
-public::set_mode
-public::set_args
-public::get_subcommand
-public::get_args
-public::get_args_fixed_size
-public::get_args_fixed_length
-public::specified
-public::print_dictionary
-
-public::dget,iget,lget,rget,sget,cget
-public::dgets,igets,lgets,rgets,sgets,cgets
-
-private::check_commandline
-private::wipe_dictionary
-private::prototype_to_dictionary
-private::update
-private::prototype_and_cmd_args_to_nlist
-private::get
-
-type option
-character(:),allocatable::shortname
-character(:),allocatable::longname
-character(:),allocatable::value
-integer::length
-logical::present_in
-logical::mandatory
-end type option
-!===================================================================================================================================
-character(len=:),allocatable,save::keywords(:)
-character(len=:),allocatable,save::shorts(:)
-character(len=:),allocatable,save::values(:)
-integer,allocatable,save::counts(:)
-logical,allocatable,save::present_in(:)
-logical,allocatable,save::mandatory(:)
-
-logical,save::G_DEBUG=.false.
-logical,save::G_UNDERDASH=.false.
-logical,save::G_IGNORECASE=.false.
-logical,save::G_STRICT=.false.! strict short and long rules or allow -longname and --shortname
+!! ! for fixed-length strings
+!! call get_args_fixed_length('label',label)
+!!
+!! ! for non-allocatable arrays
+!! call get_args_fixed_size('p',p)
+!! call get_args_fixed_size('logi',logi)
+!! !
+!! ! all done parsing, use values
+!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z
+!! write(*,*)'p=',p
+!! write(*,*)'point=',point
+!! write(*,*)'title=',title
+!! write(*,*)'label=',label
+!! write(*,*)'l=',l
+!! write(*,*)'L=',lbig
+!! write(*,*)'logicals=',logicals
+!! write(*,*)'logi=',logi
+!! !
+!! ! unnamed strings
+!! !
+!! if(size(filenames) > 0)then
+!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
+!! endif
+!! !
+!! end program demo_M_CLI2
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!!##SEE ALSO
+!! + get_args(3f)
+!! + get_args_fixed_size(3f)
+!! + get_args_fixed_length(3f)
+!! + get_subcommand(3f)
+!! + set_mode(3f)
+!! + specified(3f)
+!!
+!! Note that the convenience routines are described under get_args(3f):
+!! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),
+!! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f)
+!===================================================================================================================================
+module M_CLI2
+use,intrinsic::iso_fortran_env,only:stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT,warn=>OUTPUT_UNIT
+implicit none
+private
+
+integer,parameter,private::dp=kind(0.0d0)
+integer,parameter,private::sp=kind(0.0)
+
+character(len=*),parameter::gen='(*(g0))'
+character(len=:),allocatable,public::unnamed(:)
+character(len=:),allocatable,public::args(:)
+character(len=:),allocatable,public::remaining
+public::set_mode
+public::set_args
+public::get_subcommand
+public::get_args
+public::get_args_fixed_size
+public::get_args_fixed_length
+public::specified
+public::print_dictionary
-logical,save::G_keyword_single_letter=.true.
-character(len=:),allocatable,save::G_passed_in
-logical,save::G_remaining_on,G_remaining_option_allowed
-character(len=:),allocatable,save::G_remaining
-character(len=:),allocatable,save::G_subcommand! possible candidate for a subcommand
-character(len=:),allocatable,save::G_STOP_MESSAGE
-integer,save::G_STOP
-logical,save::G_QUIET
-character(len=:),allocatable,save::G_PREFIX
-!----------------------------------------------
-! try out response files
-! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file')
-logical,save,public::CLI_RESPONSE_FILE=.false.! allow @name abbreviations
-logical,save::G_APPEND! whether to append or replace when duplicate keywords found
-logical,save::G_OPTIONS_ONLY! process response file only looking for options for get_subcommand()
-logical,save::G_RESPONSE! allow @name abbreviations
-character(len=:),allocatable,save::G_RESPONSE_IGNORED
-!----------------------------------------------
-!===================================================================================================================================
-! return allocatable arrays
-interface get_args;module procedure get_anyarray_d;end interface! any size array
-interface get_args;module procedure get_anyarray_i;end interface! any size array
-interface get_args;module procedure get_anyarray_r;end interface! any size array
-interface get_args;module procedure get_anyarray_x;end interface! any size array
-interface get_args;module procedure get_anyarray_c;end interface! any size array and any length
-interface get_args;module procedure get_anyarray_l;end interface! any size array
-
-! return scalars
-interface get_args;module procedure get_scalar_d;end interface
-interface get_args;module procedure get_scalar_i;end interface
-interface get_args;module procedure get_scalar_real;end interface
-interface get_args;module procedure get_scalar_complex;end interface
-interface get_args;module procedure get_scalar_logical;end interface
-interface get_args;module procedure get_scalar_anylength_c;end interface! any length
-! multiple scalars
-interface get_args;module procedure many_args;end interface
-!==================================================================================================================================
-! return non-allocatable arrays
-! said in conflict with get_args_*. Using class to get around that.
-! that did not work either. Adding size parameter as optional parameter works; but using a different name
-interface get_args_fixed_size;module procedure get_fixedarray_class;end interface! any length, fixed size array
-!interface get_args; module procedure get_fixedarray_d; end interface
-!interface get_args; module procedure get_fixedarray_i; end interface
-!interface get_args; module procedure get_fixedarray_r; end interface
-!interface get_args; module procedure get_fixedarray_l; end interface
-!interface get_args; module procedure get_fixedarray_fixed_length_c; end interface
-
-interface get_args_fixed_length;module procedure get_args_fixed_length_a_array;end interface! fixed length any size array
-interface get_args_fixed_length;module procedure get_args_fixed_length_scalar_c;end interface! fixed length
-!===================================================================================================================================
-!intrinsic findloc
-!===================================================================================================================================
-
-! ident_1="@(#) M_CLI2 str(3f) {msg_scalar msg_one}"
-
-private str
-interface str
-module procedure msg_scalar,msg_one
-end interface str
-!===================================================================================================================================
-
-private locate_! [M_CLI2] find PLACE in sorted character array where value can be found or should be placed
-private locate_c
-private insert_! [M_CLI2] insert entry into a sorted allocatable array at specified position
-private insert_c
-private insert_i
-private insert_l
-private replace_! [M_CLI2] replace entry by index from a sorted allocatable array if it is present
-private replace_c
-private replace_i
-private replace_l
-private remove_! [M_CLI2] delete entry by index from a sorted allocatable array if it is present
-private remove_c
-private remove_i
-private remove_l
-
-! Generic subroutine inserts element into allocatable array at specified position
-interface locate_;module procedure locate_c;end interface
-interface insert_;module procedure insert_c,insert_i,insert_l;end interface
-interface replace_;module procedure replace_c,replace_i,replace_l;end interface
-interface remove_;module procedure remove_c,remove_i,remove_l;end interface
-!-----------------------------------------------------------------------------------------------------------------------------------
-! convenience functions
-interface cgets;module procedure cgs,cg;end interface
-interface dgets;module procedure dgs,dg;end interface
-interface igets;module procedure igs,ig;end interface
-interface lgets;module procedure lgs,lg;end interface
-interface rgets;module procedure rgs,rg;end interface
-interface sgets;module procedure sgs,sg;end interface
-!-----------------------------------------------------------------------------------------------------------------------------------
-contains
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process
-!! pre-defined options
-!!
-!!##SYNOPSIS
-!!
-!! subroutine check_commandline(help_text,version_text,ierr,errmsg)
-!!
-!! character(len=*),intent(in),optional :: help_text(:)
-!! character(len=*),intent(in),optional :: version_text(:)
+public::dget,iget,lget,rget,sget,cget
+public::dgets,igets,lgets,rgets,sgets,cgets
+
+type option
+character(:),allocatable::shortname
+character(:),allocatable::longname
+character(:),allocatable::value
+integer::length
+logical::present_in
+logical::mandatory
+end type option
+
+character(len=:),allocatable,save::keywords(:)
+character(len=:),allocatable,save::shorts(:)
+character(len=:),allocatable,save::values(:)
+integer,allocatable,save::counts(:)
+logical,allocatable,save::present_in(:)
+logical,allocatable,save::mandatory(:)
+
+logical,save::G_DEBUG=.false.
+logical,save::G_UNDERDASH=.false.
+logical,save::G_NOSEPARATOR=.false.
+logical,save::G_IGNORECASE=.false.! ignore case of long keywords
+logical,save::G_STRICT=.false.! strict short and long rules or allow -longname and --shortname
+logical,save::G_APPEND=.true.! whether to append or replace when duplicate keywords found
+
+logical,save::G_keyword_single_letter=.true.
+character(len=:),allocatable,save::G_passed_in
+logical,save::G_remaining_on,G_remaining_option_allowed
+character(len=:),allocatable,save::G_remaining
+character(len=:),allocatable,save::G_subcommand! possible candidate for a subcommand
+character(len=:),allocatable,save::G_STOP_MESSAGE
+integer,save::G_STOP
+logical,save::G_QUIET
+character(len=:),allocatable,save::G_PREFIX
+
+! try out response files
+! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file')
+logical,save,public::CLI_RESPONSE_FILE=.false.! allow @name abbreviations
+logical,save::G_OPTIONS_ONLY! process response file only looking for options for get_subcommand()
+logical,save::G_RESPONSE! allow @name abbreviations
+character(len=:),allocatable,save::G_RESPONSE_IGNORED
+
+! return allocatable arrays
+interface get_args;module procedure get_anyarray_d;end interface! any size array
+interface get_args;module procedure get_anyarray_i;end interface! any size array
+interface get_args;module procedure get_anyarray_r;end interface! any size array
+interface get_args;module procedure get_anyarray_x;end interface! any size array
+interface get_args;module procedure get_anyarray_c;end interface! any size array and any length
+interface get_args;module procedure get_anyarray_l;end interface! any size array
+
+! return scalars
+interface get_args;module procedure get_scalar_d;end interface
+interface get_args;module procedure get_scalar_i;end interface
+interface get_args;module procedure get_scalar_real;end interface
+interface get_args;module procedure get_scalar_complex;end interface
+interface get_args;module procedure get_scalar_logical;end interface
+interface get_args;module procedure get_scalar_anylength_c;end interface! any length
+
+! multiple scalars
+interface get_args;module procedure many_args;end interface
+
+! return non-allocatable arrays
+! said in conflict with get_args_*. Using class to get around that.
+! that did not work either. Adding size parameter as optional parameter works; but using a different name
+interface get_args_fixed_size;module procedure get_fixedarray_class;end interface! any length, fixed size array
+!interface get_args; module procedure get_fixedarray_d; end interface
+!interface get_args; module procedure get_fixedarray_i; end interface
+!interface get_args; module procedure get_fixedarray_r; end interface
+!interface get_args; module procedure get_fixedarray_l; end interface
+!interface get_args; module procedure get_fixedarray_fixed_length_c; end interface
+
+interface get_args_fixed_length;module procedure get_args_fixed_length_a_array;end interface! fixed length any size array
+interface get_args_fixed_length;module procedure get_args_fixed_length_scalar_c;end interface! fixed length
+
+! Generic subroutine inserts element into allocatable array at specified position
+
+! find PLACE in sorted character array where value can be found or should be placed
+interface locate_;module procedure locate_c;end interface
+
+! insert entry into a sorted allocatable array at specified position
+interface insert_;module procedure insert_c,insert_i,insert_l;end interface
+
+! replace entry by index from a sorted allocatable array if it is present
+interface replace_;module procedure replace_c,replace_i,replace_l;end interface
+
+! delete entry by index from a sorted allocatable array if it is present
+interface remove_;module procedure remove_c,remove_i,remove_l;end interface
+
+! convenience functions
+interface cgets;module procedure cgs,cg;end interface
+interface dgets;module procedure dgs,dg;end interface
+interface igets;module procedure igs,ig;end interface
+interface lgets;module procedure lgs,lg;end interface
+interface rgets;module procedure rgs,rg;end interface
+interface sgets;module procedure sgs,sg;end interface
+
+contains
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process
+!! pre-defined options!!
-!!##DESCRIPTION
-!! Checks the commandline and processes the implicit --help, --version,
-!! --verbose, and --usage parameters.
+!!##SYNOPSIS
+!!
+!! subroutine check_commandline(help_text,version_text,ierr,errmsg)!!
-!! If the optional text values are supplied they will be displayed by
-!! --help and --version command-line options, respectively.
+!! character(len=*),intent(in),optional :: help_text(:)
+!! character(len=*),intent(in),optional :: version_text(:)!!
-!!##OPTIONS
-!!
-!! HELP_TEXT if present, will be displayed if program is called with
-!! --help switch, and then the program will terminate. If
-!! not supplied, the command line initialized string will be
-!! shown when --help is used on the commandline.
+!!##DESCRIPTION
+!! Checks the commandline and processes the implicit --help, --version,
+!! --verbose, and --usage parameters.
+!!
+!! If the optional text values are supplied they will be displayed by
+!! --help and --version command-line options, respectively.!!
-!! VERSION_TEXT if present, will be displayed if program is called with
-!! --version switch, and then the program will terminate.
-!!
-!! If the first four characters of each line are "@(#)" this prefix
-!! will not be displayed and the last non-blank letter will be
-!! removed from each line. This if for support of the SCCS what(1)
-!! command. If you do not have the what(1) command on GNU/Linux and
-!! Unix platforms you can probably see how it can be used to place
-!! metadata in a binary by entering:
+!!##OPTIONS
+!!
+!! HELP_TEXT if present, will be displayed if program is called with
+!! --help switch, and then the program will terminate. If
+!! not supplied, the command line initialized string will be
+!! shown when --help is used on the commandline.
+!!
+!! VERSION_TEXT if present, will be displayed if program is called with
+!! --version switch, and then the program will terminate.!!
-!! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g'
-!!
-!!##EXAMPLE
-!!
-!!
-!! Typical usage:
+!! If the first four characters of each line are "@(#)" this prefix
+!! will not be displayed and the last non-blank letter will be
+!! removed from each line. This if for support of the SCCS what(1)
+!! command. If you do not have the what(1) command on GNU/Linux and
+!! Unix platforms you can probably see how it can be used to place
+!! metadata in a binary by entering:!!
-!! program check_commandline
-!! use M_CLI2, only : unnamed, set_args, get_args
-!! implicit none
-!! integer :: i
-!! character(len=:),allocatable :: version_text(:), help_text(:)
-!! real :: x, y, z
-!! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3'
-!! version_text=[character(len=80) :: "version 1.0","author: me"]
-!! help_text=[character(len=80) :: &
-!! & "wish I put instructions","here","I suppose?"]
-!! call set_args(cmd,help_text,version_text)
-!! call get_args('x',x,'y',y,'z',z)
-!! ! All done cracking the command line. Use the values in your program.
-!! write (*,*)x,y,z
-!! ! the optional unnamed values on the command line are
-!! ! accumulated in the character array "UNNAMED"
-!! if(size(unnamed) > 0)then
-!! write (*,'(a)')'files:'
-!! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed))
-!! endif
-!! end program check_commandline
-!===================================================================================================================================
-subroutine check_commandline(help_text,version_text)
-character(len=*),intent(in),optional::help_text(:)
-character(len=*),intent(in),optional::version_text(:)
-character(len=:),allocatable::line
-integer::i
-integer::istart
-integer::iback
-if(get('usage')=='T')then
- call print_dictionary('USAGE:')
-!x!call default_help()
-call mystop(32)
-return
- endif
- if(present(help_text))then
- if(get('help')=='T')then
- do i=1,size(help_text)
-call journal('sc',help_text(i))
-enddo
- call mystop(1,'displayed help text')
-return
- endif
-elseif(get('help')=='T')then
- call default_help()
-call mystop(2,'displayed default help text')
-return
- endif
- if(present(version_text))then
- if(get('version')=='T')then
-istart=1
-iback=0
-if(size(version_text)>0)then
- if(index(version_text(1),'@'//'(#)')==1)then! allow for what(1) syntax
-istart=5
-iback=1
-endif
- endif
- do i=1,size(version_text)
-!xINTEL BUG*!call journal('sc',version_text(i)(istart:len_trim(version_text(i))-iback))
-line=version_text(i)(istart:len_trim(version_text(i))-iback)
-call journal('sc',line)
-enddo
- call mystop(3,'displayed version text')
-return
- endif
-elseif(get('version')=='T')then
-
- if(G_QUIET)then
-G_STOP_MESSAGE='no version text'
-else
- call journal('sc','*check_commandline* no version text')
-endif
- call mystop(4,'displayed default version text')
-return
- endif
-contains
-subroutine default_help()
-character(len=:),allocatable::cmd_name
-integer::ilength
-call get_command_argument(number=0,length=ilength)
-if(allocated(cmd_name))deallocate(cmd_name)
-allocate(character(len=ilength)::cmd_name)
-call get_command_argument(number=0,value=cmd_name)
-G_passed_in=G_passed_in//repeat(' ',len(G_passed_in))
-call substitute(G_passed_in,' --',NEW_LINE('A')//' --')
-if(.not.G_QUIET)then
- call journal('sc',cmd_name,G_passed_in)! no help text, echo command and default options
-endif
- deallocate(cmd_name)
-end subroutine default_help
-end subroutine check_commandline
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine set_args(definition,help_text,version_text,ierr,errmsg)
-!!
-!! character(len=*),intent(in),optional :: definition
-!! character(len=*),intent(in),optional :: help_text(:)
-!! character(len=*),intent(in),optional :: version_text(:)
-!! integer,intent(out),optional :: ierr
-!! character(len=:),intent(out),allocatable,optional :: errmsg
-!!##DESCRIPTION
-!!
-!! SET_ARGS(3f) requires a unix-like command prototype for defining
-!! arguments and default command-line options. Argument values are then
-!! read using GET_ARGS(3f).
-!!
-!! The --help and --version options require the optional
-!! help_text and version_text values to be provided.
-!!
-!!##OPTIONS
-!!
-!! DEFINITION composed of all command arguments concatenated
-!! into a Unix-like command prototype string. For
-!! example:
-!!
-!! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3')
+!! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g'
+!!
+!!##EXAMPLE
+!!
+!!
+!! Typical usage:
+!!
+!! program check_commandline
+!! use M_CLI2, only : unnamed, set_args, get_args
+!! implicit none
+!! integer :: i
+!! character(len=:),allocatable :: version_text(:), help_text(:)
+!! real :: x, y, z
+!! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3'
+!! version_text=[character(len=80) :: "version 1.0","author: me"]
+!! help_text=[character(len=80) :: &
+!! & "wish I put instructions","here","I suppose?"]
+!! call set_args(cmd,help_text,version_text)
+!! call get_args('x',x,'y',y,'z',z)
+!! ! All done cracking the command line. Use the values in your program.
+!! write (*,*)x,y,z
+!! ! the optional unnamed values on the command line are
+!! ! accumulated in the character array "UNNAMED"
+!! if(size(unnamed) > 0)then
+!! write (*,'(a)')'files:'
+!! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed))
+!! endif
+!! end program check_commandline
+!===================================================================================================================================
+subroutine check_commandline(help_text,version_text)
+character(len=*),intent(in),optional::help_text(:)
+character(len=*),intent(in),optional::version_text(:)
+character(len=:),allocatable::line
+integer::i
+integer::istart
+integer::iback
+if(get('usage')=='T')then
+ call print_dictionary('USAGE:')
+call mystop(32)
+return
+ endif
+ if(present(help_text))then
+ if(get('help')=='T')then
+ do i=1,size(help_text)
+call journal(help_text(i))
+enddo
+ call mystop(1,'displayed help text')
+return
+ endif
+elseif(get('help')=='T')then
+ call default_help()
+call mystop(2,'displayed default help text')
+return
+ endif
+ if(present(version_text))then
+ if(get('version')=='T')then
+istart=1
+iback=0
+if(size(version_text)>0)then
+ if(index(version_text(1),'@'//'(#)')==1)then! allow for what(1) syntax
+istart=5
+iback=1
+endif
+ endif
+ do i=1,size(version_text)
+!xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback))
+line=version_text(i)(istart:len_trim(version_text(i))-iback)
+call journal(line)
+enddo
+ call mystop(3,'displayed version text')
+return
+ endif
+elseif(get('version')=='T')then
+
+ if(G_QUIET)then
+G_STOP_MESSAGE='no version text'
+else
+ call journal('*check_commandline* no version text')
+endif
+ call mystop(4,'displayed default version text')
+return
+ endif
+contains
+subroutine default_help()
+character(len=:),allocatable::cmd_name
+integer::ilength
+call get_command_argument(number=0,length=ilength)
+if(allocated(cmd_name))deallocate(cmd_name)
+allocate(character(len=ilength)::cmd_name)
+call get_command_argument(number=0,value=cmd_name)
+G_passed_in=G_passed_in//repeat(' ',len(G_passed_in))
+G_passed_in=replace_str(G_passed_in,' --',NEW_LINE('A')//' --')
+if(.not.G_QUIET)then
+ call journal(cmd_name,G_passed_in)! no help text, echo command and default options
+endif
+ deallocate(cmd_name)
+end subroutine default_help
+end subroutine check_commandline
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine set_args(prototype,help_text,version_text,ierr,errmsg)
+!!
+!! character(len=*),intent(in),optional :: prototype
+!! character(len=*),intent(in),optional :: help_text(:)
+!! character(len=*),intent(in),optional :: version_text(:)
+!! integer,intent(out),optional :: ierr
+!! character(len=:),intent(out),allocatable,optional :: errmsg
+!!##DESCRIPTION
+!!
+!! SET_ARGS(3f) requires a unix-like command prototype which defines
+!! the command-line options and their default values. When the program
+!! is executed this and the command-line options are applied and the
+!! resulting values are placed in an internal table for retrieval via
+!! GET_ARGS(3f).
+!!
+!! The built-in --help and --version options require optional help_text
+!! and version_text values to be provided to be particularly useful.!!
-!! DEFINITION is pre-defined to act as if started with
-!! the reserved options '--verbose F --usage F --help
-!! F --version F'. The --usage option is processed when
-!! the set_args(3f) routine is called. The same is true
-!! for --help and --version if the optional help_text
-!! and version_text options are provided.
-!!
-!! see "DEFINING THE PROTOTYPE" in the next section for
-!! further details.
-!!
-!! HELP_TEXT if present, will be displayed if program is called with
-!! --help switch, and then the program will terminate. If
-!! not supplied, the command line initialization string
-!! will be shown when --help is used on the commandline.
-!!
-!! VERSION_TEXT if present, will be displayed if program is called with
-!! --version switch, and then the program will terminate.
-!! IERR if present a non-zero option is returned when an
-!! error occurs instead of program execution being
-!! terminated
-!! ERRMSG a description of the error if ierr is present
-!!
-!!##DEFINING THE PROTOTYPE
-!!
-!! o all keywords on the prototype MUST get a value.
+!!##OPTIONS
+!!
+!! PROTOTYPE composed of all command arguments concatenated
+!! into a Unix-like command prototype string. For
+!! example:
+!!
+!! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3')
+!!
+!! The following options are predefined for all commands:
+!! '--verbose F --usage F --help F --version F'.
+!!
+!! see "DEFINING THE PROTOTYPE" in the next section for
+!! further details.
+!!
+!! HELP_TEXT if present, will be displayed when the program is called with
+!! a --help switch, and then the program will terminate. If
+!! help text is not supplied the command line initialization
+!! string will be echoed.
+!!
+!! VERSION_TEXT if present, any version text defined will be displayed
+!! when the program is called with a --version switch,
+!! and then the program will terminate.
+!! IERR if present a non-zero option is returned when an
+!! error occurs instead of the program terminating.
+!! ERRMSG a description of the error if ierr is present.!!
-!! + logicals must be set to F or T.
+!!##DEFINING THE PROTOTYPE!!
-!! + strings must be delimited with double-quotes and
-!! must be at least one space. Internal double-quotes
-!! are represented with two double-quotes.
-!!
-!! o numeric keywords are not allowed; but this allows
-!! negative numbers to be used as values.
+!! o Keywords start with a single dash for short single-character
+!! keywords, and with two dashes for longer keywords.
+!!
+!! o all keywords on the prototype MUST get a value.
+!!
+!! * logicals must be set to an unquoted F.!!
-!! o lists of values should be comma-delimited unless a
-!! user-specified delimiter is used. The prototype
-!! must use the same array delimiters as the call to
-!! get the value.
-!!
-!! o to define a zero-length allocatable array make the
-!! value a delimiter (usually a comma).
-!!
-!! o all unused values go into the character array UNNAMED
-!!
-!! LONG AND SHORT NAMES
+!! * strings must be delimited with double-quotes.
+!! Since internal double-quotes are represented with two
+!! double-quotes the string must be at least one space.
+!!
+!! o numeric keywords are not allowed; but this allows
+!! negative numbers to be used as values.
+!!
+!! o lists of values should be comma-delimited unless a
+!! user-specified delimiter is used. The prototype
+!! must use the same array delimiters as the call to
+!! get the value.!!
-!! o It is recommended long names (--keyword) should be all lowercase
-!! but are case-sensitive by default, unless set_mode('ignorecase')
-!! is in effect.
+!! o to define a zero-length allocatable array make the
+!! value a delimiter (usually a comma) or an empty set
+!! of braces ("[]").!!
-!! o Long names should always be more than one character.
+!! LONG AND SHORT NAMES!!
-!! o The recommended way to have short names is to suffix the long
-!! name with :LETTER in the definition. If this syntax is used
-!! then logical shorts may be combined on the command line.
-!!
-!! Mapping of short names to long names __not__ using the
-!! --LONGNAME:SHORTNAME syntax is demonstrated in the manpage
-!! for SPECIFIED(3f).
-!!
-!! SPECIAL BEHAVIORS
-!!
-!! o A very special behavior occurs if the keyword name ends in ::.
-!! When the program is called the next parameter is taken as
-!! a value even if it starts with -. This is not generally
-!! recommended but is useful in rare cases where non-numeric
-!! values starting with a dash are desired.
-!!
-!! o If the prototype ends with "--" a special mode is turned
-!! on where anything after "--" on input goes into the variable
-!! REMAINING and the array ARGS instead of becoming elements in
-!! the UNNAMED array. This is not needed for normal processing.
-!!
-!!##USAGE
-!! When invoking the program line note that (subject to change) the
-!! following variations from other common command-line parsers:
-!!
-!! o values for duplicate keywords are appended together with a space
-!! separator when a command line is executed.
-!!
-!! o Although not generally recommended you can equivalence
-!! keywords (usually for multi-lingual support). Be aware that
-!! specifying both names of an equivalenced keyword on a command
-!! line will have undefined results (currently, their ASCII
-!! alphabetical order will define what the Fortran variable
-!! values become).
+!! Long keywords start with two dashes followed by more than one letter.
+!! Short keywords are a dash followed by a single letter.
+!!
+!! o It is recommended long names (--keyword) should be all lowercase
+!! but are case-sensitive by default, unless "set_mode('ignorecase')"
+!! is in effect.
+!!
+!! o Long names should always be more than one character.
+!!
+!! o The recommended way to have short names is to suffix the long
+!! name with :LETTER in the definition.
+!!
+!! If this syntax is used then logical shorts may be combined on the
+!! command line when "set_mode('strict')" is in effect.
+!!
+!! SPECIAL BEHAVIORS
+!!
+!! o A special behavior occurs if a keyword name ends in ::.
+!! When the program is called the next parameter is taken as
+!! a value even if it starts with -. This is not generally
+!! recommended but is useful in rare cases where non-numeric
+!! values starting with a dash are desired.
+!!
+!! o If the prototype ends with "--" a special mode is turned
+!! on where anything after "--" on input goes into the variable
+!! REMAINING with values double-quoted and also into the array ARGS
+!! instead of becoming elements in the UNNAMED array. This is not
+!! needed for normal processing, but was needed for a program that
+!! needed this behavior for its subcommands.
+!!
+!! That is, for a normal call all unnamed values go into UNNAMED
+!! and ARGS and REMAINING are ignored. So for
+!!
+!! call set_args('-x 10 -y 20 ')!!
-!! The second of the names should only be queried if the
-!! SPECIFIED(3f) function is .TRUE. for that name.
-!!
-!! Note that allocatable arrays cannot be EQUIVALENCEd in Fortran.
-!!
-!! o short Boolean keywords cannot be combined reliably unless
-!! "set_mode('strict')" is in effect. Short names that require
-!! a value cannot be bundled together. Non-Boolean key names may
-!! not be bundled.
+!! A program invocation such as
+!!
+!! xx a b c -- A B C " dd "
+!!
+!! results in
+!!
+!! UNNAMED= ['a','b','c','A','B','C',' dd']
+!! REMAINING= ''
+!! ARGS= [character(len=0) :: ] ! ie, an empty character array!!
-!! o shuffling is not supported. Values immediately follow their
-!! keywords.
-!!
-!! o if a parameter value of just "-" is supplied it is
-!! converted to the string "stdin".
+!! Whereas
+!!
+!! call set_args('-x 10 -y 20 --')
+!!
+!! generates the following output from the same program execution:!!
-!! o values not matching a keyword go into the character
-!! array "UNUSED".
-!!
-!! o if the keyword "--" is encountered on the command line the
-!! rest of the command arguments go into the character array
-!! "UNUSED".
-!!##EXAMPLE
-!!
+!! UNNAMED= ['a','b','c']
+!! REMAINING= '"A" "B" "C" " dd "'
+!! ARGS= ['A','B','C,' dd']
+!!
+!!##USAGE NOTES
+!! When invoking the program line note the (subject to change)
+!! following restrictions (which often differ between various
+!! command-line parsers):!!
-!! Sample program:
-!!
-!! program demo_set_args
-!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
-!! use M_CLI2, only : get_args_fixed_size
-!! implicit none
-!! integer :: i
-!! ! DEFINE ARGS
-!! real :: x, y, z
-!! real :: p(3)
-!! character(len=:),allocatable :: title
-!! logical :: l, lbig
-!! integer,allocatable :: ints(:)
-!! !
-!! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS)
-!! ! AND READ COMMAND LINE
-!! call set_args(' &
-!! ! reals
-!! & -x 1 -y 2.3 -z 3.4e2 &
-!! ! integer array
-!! & -p -1,-2,-3 &
-!! ! always double-quote strings
-!! & --title "my title" &
-!! ! string should be a single character at a minimum
-!! & --label " ", &
-!! ! set all logical values to F or T.
-!! & -l F -L F &
-!! ! set allocatable size to zero if you like by using a delimiter
-!! & --ints , &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! ! SCALARS
-!! call get_args('x',x)
-!! call get_args('y',y)
-!! call get_args('z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! call get_args('ints',ints) ! ALLOCATABLE ARRAY
-!! call get_args('title',title) ! ALLOCATABLE STRING
-!! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY
-!! ! USE VALUES
-!! write(*,*)'x=',x
-!! write(*,*)'y=',y
-!! write(*,*)'z=',z
-!! write(*,*)'p=',p
-!! write(*,*)'title=',title
-!! write(*,*)'ints=',ints
-!! write(*,*)'l=',l
-!! write(*,*)'L=',lbig
-!! ! UNNAMED VALUES
-!! if(size(filenames) > 0)then
-!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
-!! endif
-!! end program demo_set_args
-!!
-!!##RESPONSE FILES
-!!
-!! If you have no interest in using external files as abbreviations
-!! you can ignore this section. Otherwise, before calling set_args(3f)
-!! add:
-!!
-!! use M_CLI2, only : set_mode
-!! call set_mode('response_file')
-!!
-!! M_CLI2 Response files are small files containing CLI (Command Line
-!! Interface) arguments that end with ".rsp" that can be used when command
-!! lines are so long that they would exceed line length limits or so complex
-!! that it is useful to have a platform-independent method of creating
-!! an abbreviation.
-!!
-!! Shell aliases and scripts are often used for similar purposes (and
-!! allow for much more complex conditional execution, of course), but
-!! they generally cannot be used to overcome line length limits and are
-!! typically platform-specific.
-!!
-!! Examples of commands that support similar response files are the Clang
-!! and Intel compilers, although there is no standard format for the files.
-!!
-!! They are read if you add options of the syntax "@NAME" as the FIRST
-!! parameters on your program command line calls. They are not recursive --
-!! that is, an option in a response file cannot be given the value "@NAME2"
-!! to call another response file.
+!! o values for duplicate keywords are appended together with a space
+!! separator when a command line is executed by default.
+!!
+!! o shuffling is not supported. Values immediately follow their
+!! keywords.
+!!
+!! o Only short Boolean keywords can be bundled together.
+!! If allowing bundling is desired call "set_mode('strict')".
+!! This will require prefixing long names with "--" and short
+!! names with "-". Otherwise M_CLI2 relaxes that requirement
+!! and mostly does not care what prefix is used for a keyword.
+!! But this would make it unclear what was meant by "-ox" if
+!! allowed options were "-o F -x F --ox F " for example, so
+!! "strict" mode is required to remove the ambiguity.
+!!
+!! o if a parameter value of just "-" is supplied it is
+!! converted to the string "stdin".
+!!
+!! o values not needed for a keyword value go into the character
+!! array "UNNAMED".
+!!
+!! In addition if the keyword "--" is encountered on the command
+!! line the rest of the command line goes into the character array
+!! "UNNAMED".
+!!
+!!##EXAMPLE
+!!
+!!
+!! Sample program:
+!!
+!! program demo_set_args
+!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
+!! use M_CLI2, only : get_args_fixed_size
+!! implicit none
+!! integer :: i
+!! ! DEFINE ARGS
+!! real :: x, y, z
+!! real :: p(3)
+!! character(len=:),allocatable :: title
+!! logical :: l, lbig
+!! integer,allocatable :: ints(:)
+!! !
+!! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS)
+!! ! AND READ COMMAND LINE
+!! call set_args(' &
+!! ! reals
+!! & -x 1 -y 2.3 -z 3.4e2 &
+!! ! integer array
+!! & -p -1,-2,-3 &
+!! ! always double-quote strings
+!! & --title "my title" &
+!! ! string should be a single character at a minimum
+!! & --label " ", &
+!! ! set all logical values to F
+!! & -l F -L F &
+!! ! set allocatable size to zero if you like by using a delimiter
+!! & --ints , &
+!! & ')
+!! ! ASSIGN VALUES TO ELEMENTS
+!! ! SCALARS
+!! call get_args('x',x)
+!! call get_args('y',y)
+!! call get_args('z',z)
+!! call get_args('l',l)
+!! call get_args('L',lbig)
+!! call get_args('ints',ints) ! ALLOCATABLE ARRAY
+!! call get_args('title',title) ! ALLOCATABLE STRING
+!! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY
+!! ! USE VALUES
+!! write(*,*)'x=',x
+!! write(*,*)'y=',y
+!! write(*,*)'z=',z
+!! write(*,*)'p=',p
+!! write(*,*)'title=',title
+!! write(*,*)'ints=',ints
+!! write(*,*)'l=',l
+!! write(*,*)'L=',lbig
+!! ! UNNAMED VALUES
+!! if(size(filenames) > 0)then
+!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
+!! endif
+!! end program demo_set_args!!
-!! More than one response name may appear on a command line.
+!!##RESPONSE FILES!!
-!! They are case-sensitive names.
-!!
-!! Note "@" s a special character in Powershell, and requires being escaped
-!! with a grave character.
-!!
-!! LOCATING RESPONSE FILES
+!! If you have no interest in using external files as abbreviations
+!! you can ignore this section. Otherwise, before calling set_args(3f)
+!! add:
+!!
+!! use M_CLI2, only : set_mode
+!! call set_mode('response_file')!!
-!! A search for the response file always starts with the current directory.
-!! The search then proceeds to look in any additional directories specified
-!! with the colon-delimited environment variable CLI_RESPONSE_PATH.
-!!
-!! The first resource file found that results in lines being processed
-!! will be used and processing stops after that first match is found. If
-!! no match is found an error occurs and the program is stopped.
-!!
-!! RESPONSE FILE SECTIONS
-!!
-!! A simple response file just has options for calling the program in it
-!! prefixed with the word "options".
-!! But they can also contain section headers to denote selections that are
-!! only executed when a specific OS is being used, print messages, and
-!! execute system commands.
-!!
-!! SEARCHING FOR OSTYPE IN REGULAR FILES
-!!
-!! So assuming the name @NAME was specified on the command line a file
-!! named NAME.rsp will be searched for in all the search directories
-!! and then in that file a string that starts with the string @OSTYPE
-!! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE
-!! takes precedence over $OS).
-!!
-!! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES
+!! M_CLI2 Response files are small files containing CLI (Command Line
+!! Interface) arguments that end with ".rsp" that can be used when command
+!! lines are so long that they would exceed line length limits or so complex
+!! that it is useful to have a platform-independent method of creating
+!! an abbreviation.
+!!
+!! Shell aliases and scripts are often used for similar purposes (and
+!! allow for much more complex conditional execution, of course), but
+!! they generally cannot be used to overcome line length limits and are
+!! typically platform-specific.
+!!
+!! Examples of commands that support similar response files are the Clang
+!! and Intel compilers, although there is no standard format for the files.
+!!
+!! They are read if you add options of the syntax "@NAME" as the FIRST
+!! parameters on your program command line calls. They are not recursive --
+!! that is, an option in a response file cannot be given the value "@NAME2"
+!! to call another response file.
+!!
+!! More than one response name may appear on a command line.
+!!
+!! They are case-sensitive names.
+!!
+!! Note "@" s a special character in Powershell, and requires being escaped
+!! with a grave character.!!
-!! Then, the same files will be searched for lines above any line starting
-!! with "@". That is, if there is no special section for the current OS
-!! it just looks at the top of the file for unlabeled options.
-!!
-!! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE
+!! LOCATING RESPONSE FILES
+!!
+!! A search for the response file always starts with the current directory.
+!! The search then proceeds to look in any additional directories specified
+!! with the colon-delimited environment variable CLI_RESPONSE_PATH.!!
-!! In addition or instead of files with the same name as the @NAME option
-!! on the command line, you can have one file named after the executable
-!! name that contains multiple abbreviation names.
+!! The first resource file found that results in lines being processed
+!! will be used and processing stops after that first match is found. If
+!! no match is found an error occurs and the program is stopped.!!
-!! So if your program executable is named EXEC you create a single file
-!! called EXEC.rsp and can append all the simple files described above
-!! separating them with lines of the form @OSTYPE@NAME or just @NAME.
-!!
-!! So if no specific file for the abbreviation is found a file called
-!! "EXEC.rsp" is searched for where "EXEC" is the name of the executable.
-!! This file is always a "compound" response file that uses the following format:
+!! RESPONSE FILE SECTIONS
+!!
+!! A simple response file just has options for calling the program in it
+!! prefixed with the word "options".
+!! But they can also contain section headers to denote selections that are
+!! only executed when a specific OS is being used, print messages, and
+!! execute system commands.!!
-!! Any compound EXEC.rsp file found in the current or searched directories
-!! will be searched for the string @OSTYPE@NAME first.
-!!
-!! Then if nothing is found, the less specific line @NAME is searched for.
-!!
-!! THE SEARCH IS OVER
-!!
-!! Sounds complicated but actually works quite intuitively. Make a file in
-!! the current directory and put options in it and it will be used. If that
-!! file ends up needing different cases for different platforms add a line
-!! like "@Linux" to the file and some more lines and that will only be
-!! executed if the environment variable OSTYPE or OS is "Linux". If no match
-!! is found for named sections the lines at the top before any "@" lines
-!! will be used as a default if no match is found.
-!!
-!! If you end up using a lot of files like this you can combine them all
-!! together and put them into a file called "program_name".rsp and just
-!! put lines like @NAME or @OSTYPE@NAME at that top of each selection.
-!!
-!! Now, back to the details on just what you can put in the files.
-!!
-!!##SPECIFICATION FOR RESPONSE FILES
-!!
-!! SIMPLE RESPONSE FILES
-!!
-!! The first word of a line is special and has the following meanings:
-!!
-!! options|- Command options following the rules of the SET_ARGS(3f)
-!! prototype. So
-!! o It is preferred to specify a value for all options.
-!! o double-quote strings.
-!! o give a blank string value as " ".
-!! o use F|T for lists of logicals,
-!! o lists of numbers should be comma-delimited.
-!! o --usage, --help, --version, --verbose, and unknown
-!! options are ignored.
-!!
-!! comment|# Line is a comment line
-!! system|! System command.
-!! System commands are executed as a simple call to
-!! system (so a cd(1) or setting a shell variable
-!! would not effect subsequent lines, for example)
-!! BEFORE the command being processed.
-!! print|> Message to screen
-!! stop display message and stop program.
-!!
-!! NOTE: system commands are executed when encountered, but options are
-!! gathered from multiple option lines and passed together at the end of
-!! processing of the block; so all commands will be executed BEFORE the
-!! command for which options are being supplied no matter where they occur.
+!! SEARCHING FOR OSTYPE IN REGULAR FILES
+!!
+!! So assuming the name @NAME was specified on the command line a file
+!! named NAME.rsp will be searched for in all the search directories
+!! and then in that file a string that starts with the string @OSTYPE
+!! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE
+!! takes precedence over $OS).
+!!
+!! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES
+!!
+!! Then, the same files will be searched for lines above any line starting
+!! with "@". That is, if there is no special section for the current OS
+!! it just looks at the top of the file for unlabeled options.
+!!
+!! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE
+!!
+!! In addition or instead of files with the same name as the @NAME option
+!! on the command line, you can have one file named after the executable
+!! name that contains multiple abbreviation names.
+!!
+!! So if your program executable is named EXEC you create a single file
+!! called EXEC.rsp and can append all the simple files described above
+!! separating them with lines of the form @OSTYPE@NAME or just @NAME.
+!!
+!! So if no specific file for the abbreviation is found a file called
+!! "EXEC.rsp" is searched for where "EXEC" is the name of the executable.
+!! This file is always a "compound" response file that uses the following format:
+!!
+!! Any compound EXEC.rsp file found in the current or searched directories
+!! will be searched for the string @OSTYPE@NAME first.
+!!
+!! Then if nothing is found, the less specific line @NAME is searched for.
+!!
+!! THE SEARCH IS OVER
+!!
+!! Sounds complicated but actually works quite intuitively. Make a file in
+!! the current directory and put options in it and it will be used. If that
+!! file ends up needing different cases for different platforms add a line
+!! like "@Linux" to the file and some more lines and that will only be
+!! executed if the environment variable OSTYPE or OS is "Linux". If no match
+!! is found for named sections the lines at the top before any "@" lines
+!! will be used as a default if no match is found.
+!!
+!! If you end up using a lot of files like this you can combine them all
+!! together and put them into a file called "program_name".rsp and just
+!! put lines like @NAME or @OSTYPE@NAME at that top of each selection.
+!!
+!! Now, back to the details on just what you can put in the files.
+!!
+!!##SPECIFICATION FOR RESPONSE FILES!!
-!! So if a program that does nothing but echos its parameters
+!! SIMPLE RESPONSE FILES!!
-!! program testit
-!! use M_CLI2, only : set_args, rget, sget, lget, set_mode
-!! implicit none
-!! real :: x,y ; namelist/args/ x,y
-!! character(len=:),allocatable :: title ; namelist/args/ title
-!! logical :: big ; namelist/args/ big
-!! call set_mode('response_file')
-!! call set_args('-x 10.0 -y 20.0 --title "my title" --big F')
-!! x=rget('x')
-!! y=rget('y')
-!! title=sget('title')
-!! big=lget('big')
-!! write(*,nml=args)
-!! end program testit
-!!
-!! And a file in the current directory called "a.rsp" contains
-!!
-!! # defaults for project A
-!! options -x 1000 -y 9999
-!! options --title " "
-!! options --big T
-!!
-!! The program could be called with
-!!
-!! $myprog # normal call
-!! X=10.0 Y=20.0 TITLE="my title"
-!!
-!! $myprog @a # change defaults as specified in "a.rsp"
-!! X=1000.0 Y=9999.0 TITLE=" "
-!!
-!! # change defaults but use any option as normal to override defaults
-!! $myprog @a -y 1234
-!! X=1000.0 Y=1234.0 TITLE=" "
-!!
-!! COMPOUND RESPONSE FILES
-!!
-!! A compound response file has the same basename as the executable with a
-!! ".rsp" suffix added. So if your program is named "myprg" the filename
-!! must be "myprg.rsp".
-!!
-!! Note that here `basename` means the last leaf of the
-!! name of the program as returned by the Fortran intrinsic
-!! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period ("."),
-!! so it is a good idea not to use hidden files.
+!! The first word of a line is special and has the following meanings:
+!!
+!! options|- Command options following the rules of the SET_ARGS(3f)
+!! prototype. So
+!! o It is preferred to specify a value for all options.
+!! o double-quote strings.
+!! o give a blank string value as " ".
+!! o use F|T for lists of logicals,
+!! o lists of numbers should be comma-delimited.
+!! o --usage, --help, --version, --verbose, and unknown
+!! options are ignored.
+!!
+!! comment|# Line is a comment line
+!! system|! System command.
+!! System commands are executed as a simple call to
+!! system (so a cd(1) or setting a shell variable
+!! would not effect subsequent lines, for example)
+!! BEFORE the command being processed.
+!! print|> Message to screen
+!! stop display message and stop program.
+!!
+!! NOTE: system commands are executed when encountered, but options are
+!! gathered from multiple option lines and passed together at the end of
+!! processing of the block; so all commands will be executed BEFORE the
+!! command for which options are being supplied no matter where they occur.
+!!
+!! So if a program that does nothing but echos its parameters
+!!
+!! program testit
+!! use M_CLI2, only : set_args, rget, sget, lget, set_mode
+!! implicit none
+!! real :: x,y ; namelist/args/ x,y
+!! character(len=:),allocatable :: title ; namelist/args/ title
+!! logical :: big ; namelist/args/ big
+!! call set_mode('response_file')
+!! call set_args('-x 10.0 -y 20.0 --title "my title" --big F')
+!! x=rget('x')
+!! y=rget('y')
+!! title=sget('title')
+!! big=lget('big')
+!! write(*,nml=args)
+!! end program testit
+!!
+!! And a file in the current directory called "a.rsp" contains!!
-!! Unlike simple response files compound response files can contain multiple
-!! setting names.
-!!
-!! Specifically in a compound file
-!! if the environment variable $OSTYPE (first) or $OS is set the first search
-!! will be for a line of the form (no leading spaces should be used):
+!! # defaults for project A
+!! options -x 1000 -y 9999
+!! options --title " "
+!! options --big T
+!!
+!! The program could be called with!!
-!! @OSTYPE@alias_name
-!!
-!! If no match or if the environment variables $OSTYPE and $OS were not
-!! set or a match is not found then a line of the form
-!!
-!! @alias_name
-!!
-!! is searched for in simple or compound files. If found subsequent lines
-!! will be ignored that start with "@" until a line not starting with
-!! "@" is encountered. Lines will then be processed until another line
-!! starting with "@" is found or end-of-file is encountered.
+!! $myprog # normal call
+!! X=10.0 Y=20.0 TITLE="my title"
+!!
+!! $myprog @a # change defaults as specified in "a.rsp"
+!! X=1000.0 Y=9999.0 TITLE=" "
+!!
+!! # change defaults but use any option as normal to override defaults
+!! $myprog @a -y 1234
+!! X=1000.0 Y=1234.0 TITLE=" "
+!!
+!! COMPOUND RESPONSE FILES!!
-!! COMPOUND RESPONSE FILE EXAMPLE
-!! An example compound file
-!!
-!! #################
-!! @if
-!! > RUNNING TESTS USING RELEASE VERSION AND ifort
-!! options test --release --compiler ifort
-!! #################
-!! @gf
-!! > RUNNING TESTS USING RELEASE VERSION AND gfortran
-!! options test --release --compiler gfortran
-!! #################
-!! @nv
-!! > RUNNING TESTS USING RELEASE VERSION AND nvfortran
-!! options test --release --compiler nvfortran
-!! #################
-!! @nag
-!! > RUNNING TESTS USING RELEASE VERSION AND nagfor
-!! options test --release --compiler nagfor
-!! #
-!! #################
-!! # OS-specific example:
-!! @Linux@install
-!! #
-!! # install executables in directory (assuming install(1) exists)
-!! #
-!! system mkdir -p ~/.local/bin
-!! options run --release T --runner "install -vbp -m 0711 -t ~/.local/bin"
-!! @install
-!! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET
-!! #
+!! A compound response file has the same basename as the executable with a
+!! ".rsp" suffix added. So if your program is named "myprg" the filename
+!! must be "myprg.rsp".
+!!
+!! Note that here `basename` means the last leaf of the
+!! name of the program as returned by the Fortran intrinsic
+!! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period ("."),
+!! so it is a good idea not to use hidden files.
+!!
+!! Unlike simple response files compound response files can contain multiple
+!! setting names.
+!!
+!! Specifically in a compound file
+!! if the environment variable $OSTYPE (first) or $OS is set the first search
+!! will be for a line of the form (no leading spaces should be used):
+!!
+!! @OSTYPE@alias_name
+!!
+!! If no match or if the environment variables $OSTYPE and $OS were not
+!! set or a match is not found then a line of the form
+!!
+!! @alias_name
+!!
+!! is searched for in simple or compound files. If found subsequent lines
+!! will be ignored that start with "@" until a line not starting with
+!! "@" is encountered. Lines will then be processed until another line
+!! starting with "@" is found or end-of-file is encountered.
+!!
+!! COMPOUND RESPONSE FILE EXAMPLE
+!! An example compound file
+!!!! #################
-!! @fpm@testall
-!! #
-!! !fpm test --compiler nvfortran
-!! !fpm test --compiler ifort
-!! !fpm test --compiler gfortran
-!! !fpm test --compiler nagfor
-!! STOP tests complete. Any additional parameters were ignored
+!! @if
+!! > RUNNING TESTS USING RELEASE VERSION AND ifort
+!! options test --release --compiler ifort
+!! #################
+!! @gf
+!! > RUNNING TESTS USING RELEASE VERSION AND gfortran
+!! options test --release --compiler gfortran!! #################
-!!
-!! Would be used like
-!!
-!! fpm @install
-!! fpm @nag --
-!! fpm @testall
-!!
-!! NOTES
-!!
-!! The intel Fortran compiler now calls the response files "indirect
-!! files" and does not add the implied suffix ".rsp" to the files
-!! anymore. It also allows the @NAME syntax anywhere on the command line,
-!! not just at the beginning. -- 20201212
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!
-!!##LICENSE
-!! Public Domain
-
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg)
-
-! ident_2="@(#) M_CLI2 set_args(3f) parse prototype string"
-
-character(len=*),intent(in)::prototype
-character(len=*),intent(in),optional::help_text(:)
-character(len=*),intent(in),optional::version_text(:)
-character(len=*),intent(in),optional::string
-character(len=*),intent(in),optional::prefix
-integer,intent(out),optional::ierr
-character(len=:),intent(out),allocatable,optional::errmsg
-character(len=:),allocatable::hold! stores command line argument
-integer::ibig
-character(len=:),allocatable::debug_mode
-
-debug_mode=upper(get_env('CLI_DEBUG_MODE','FALSE'))//' '
-select case(debug_mode(1:1))
-case('Y','T')
-G_DEBUG=.true.
-end select
-
-G_response=CLI_RESPONSE_FILE
-G_options_only=.false.
-G_append=.true.
-G_passed_in=''
-G_STOP=0
-G_STOP_MESSAGE=''
-if(present(prefix))then
-G_PREFIX=prefix
-else
-G_PREFIX=''
-endif
- if(present(ierr))then
-G_QUIET=.true.
-else
-G_QUIET=.false.
-endif
-ibig=longest_command_argument()! bug in gfortran. len=0 should be fine
-IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED)
-ALLOCATE(CHARACTER(LEN=IBIG)::UNNAMED(0))
-if(allocated(args))deallocate(args)
-allocate(character(len=ibig)::args(0))
+!! @nv
+!! > RUNNING TESTS USING RELEASE VERSION AND nvfortran
+!! options test --release --compiler nvfortran
+!! #################
+!! @nag
+!! > RUNNING TESTS USING RELEASE VERSION AND nagfor
+!! options test --release --compiler nagfor
+!! #
+!! #################
+!! # OS-specific example:
+!! @Linux@install
+!! #
+!! # install executables in directory (assuming install(1) exists)
+!! #
+!! system mkdir -p ~/.local/bin
+!! options run --release T --runner "install -vbp -m 0711 -t ~/.local/bin"
+!! @install
+!! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET
+!! #
+!! #################
+!! @fpm@testall
+!! #
+!! !fpm test --compiler nvfortran
+!! !fpm test --compiler ifort
+!! !fpm test --compiler gfortran
+!! !fpm test --compiler nagfor
+!! STOP tests complete. Any additional parameters were ignored
+!! #################
+!!
+!! Would be used like
+!!
+!! fpm @install
+!! fpm @nag --
+!! fpm @testall
+!!
+!! NOTES
+!!
+!! The intel Fortran compiler now calls the response files "indirect
+!! files" and does not add the implied suffix ".rsp" to the files
+!! anymore. It also allows the @NAME syntax anywhere on the command line,
+!! not just at the beginning. -- 20201212
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!
+!!##LICENSE
+!! Public Domain
+
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg)
+
+! ident_1="@(#) M_CLI2 set_args(3f) parse prototype string"
+
+character(len=*),intent(in)::prototype
+character(len=*),intent(in),optional::help_text(:)
+character(len=*),intent(in),optional::version_text(:)
+character(len=*),intent(in),optional::string
+character(len=*),intent(in),optional::prefix
+integer,intent(out),optional::ierr
+character(len=:),intent(out),allocatable,optional::errmsg
+character(len=:),allocatable::hold! stores command line argument
+integer::ibig
+character(len=:),allocatable::debug_mode
-call wipe_dictionary()
-hold='--version F --usage F --help F --version F '//adjustl(prototype)
-call prototype_and_cmd_args_to_nlist(hold,string)
-if(allocated(G_RESPONSE_IGNORED))then
- if(G_DEBUG)write(*,gen)'<DEBUG>SET_ARGS:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED
-if(size(unnamed)/=0)write(*,*)'LOGIC ERROR'
-call split(G_RESPONSE_IGNORED,unnamed)
-endif
-
- if(.not.allocated(unnamed))then
- allocate(character(len=0)::unnamed(0))
-endif
- if(.not.allocated(args))then
- allocate(character(len=0)::args(0))
-endif
- call check_commandline(help_text,version_text)! process --help, --version, --usage
-if(present(ierr))then
-ierr=G_STOP
-endif
- if(present(errmsg))then
-errmsg=G_STOP_MESSAGE
-endif
-end subroutine set_args
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for
-!! handling subcommands on a command line
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function get_subcommand()
-!!
-!! character(len=:),allocatable :: get_subcommand
-!!
-!!##DESCRIPTION
-!! In the special case when creating a program with subcommands it
-!! is assumed the first word on the command line is the subcommand. A
-!! routine is required to handle response file processing, therefore
-!! this routine (optionally processing response files) returns that
-!! first word as the subcommand name.
-!!
-!! It should not be used by programs not building a more elaborate
-!! command with subcommands.
-!!
-!!##RETURNS
-!! NAME name of subcommand
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_get_subcommand
-!! !x! SUBCOMMANDS
-!! !x! For a command with subcommands like git(1)
-!! !x! you can make separate namelists for each subcommand.
-!! !x! You can call this program which has two subcommands (run, test),
-!! !x! like this:
-!! !x! demo_get_subcommand --help
-!! !x! demo_get_subcommand run -x -y -z -title -l -L
-!! !x! demo_get_subcommand test -title -l -L -testname
-!! !x! demo_get_subcommand run --help
-!! implicit none
-!! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
-!! real :: x=-999.0,y=-999.0,z=-999.0
-!! character(len=80) :: title="not set"
-!! logical :: l=.false.
-!! logical :: l_=.false.
-!! character(len=80) :: testname="not set"
-!! character(len=20) :: name
-!! call parse(name) !x! DEFINE AND PARSE COMMAND LINE
-!! !x! ALL DONE CRACKING THE COMMAND LINE.
-!! !x! USE THE VALUES IN YOUR PROGRAM.
-!! write(*,*)'command was ',name
-!! write(*,*)'x,y,z .... ',x,y,z
-!! write(*,*)'title .... ',title
-!! write(*,*)'l,l_ ..... ',l,l_
-!! write(*,*)'testname . ',testname
-!! contains
-!! subroutine parse(name)
-!! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
-!! use M_CLI2, only : set_args, get_args, get_args_fixed_length
-!! use M_CLI2, only : get_subcommand, set_mode
-!! character(len=*) :: name ! the subcommand name
-!! character(len=:),allocatable :: help_text(:), version_text(:)
-!! call set_mode('response_file')
-!! ! define version text
-!! version_text=[character(len=80) :: &
-!! '@(#)PROGRAM: demo_get_subcommand >', &
-!! '@(#)DESCRIPTION: My demo program >', &
-!! '@(#)VERSION: 1.0 20200715 >', &
-!! '@(#)AUTHOR: me, myself, and I>', &
-!! '@(#)LICENSE: Public Domain >', &
-!! '' ]
-!! ! general help for "demo_get_subcommand --help"
-!! help_text=[character(len=80) :: &
-!! ' allowed subcommands are ', &
-!! ' * run -l -L -title -x -y -z ', &
-!! ' * test -l -L -title ', &
-!! '' ]
-!! ! find the subcommand name by looking for first word on command
-!! ! not starting with dash
-!! name = get_subcommand()
-!! select case(name)
-!! case('run')
-!! help_text=[character(len=80) :: &
-!! ' ', &
-!! ' Help for subcommand "run" ', &
-!! ' ', &
-!! '' ]
-!! call set_args( &
-!! & '-x 1 -y 2 -z 3 --title "my title" -l F -L F',&
-!! & help_text,version_text)
-!! call get_args('x',x)
-!! call get_args('y',y)
-!! call get_args('z',z)
-!! call get_args_fixed_length('title',title)
-!! call get_args('l',l)
-!! call get_args('L',l_)
-!! case('test')
-!! help_text=[character(len=80) :: &
-!! ' ', &
-!! ' Help for subcommand "test" ', &
-!! ' ', &
-!! '' ]
-!! call set_args(&
-!! & '--title "my title" -l F -L F --testname "Test"',&
-!! & help_text,version_text)
-!! call get_args_fixed_length('title',title)
-!! call get_args('l',l)
-!! call get_args('L',l_)
-!! call get_args_fixed_length('testname',testname)
-!! case default
-!! ! process help and version
-!! call set_args(' ',help_text,version_text)
-!! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']'
-!! write(*,'(a)')[character(len=80) :: &
-!! ' allowed subcommands are ', &
-!! ' * run -l -L -title -x -y -z ', &
-!! ' * test -l -L -title ', &
-!! '' ]
-!! stop
-!! end select
-!! end subroutine parse
-!! end program demo_get_subcommand
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-function get_subcommand()result(sub)
-
-! ident_3="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"
-
-character(len=:),allocatable::sub
-character(len=:),allocatable::cmdarg
-character(len=:),allocatable::array(:)
-character(len=:),allocatable::prototype
-integer::ilongest
-integer::i
-integer::j
-G_subcommand=''
-G_options_only=.true.
-sub=''
-
-if(.not.allocated(unnamed))then
- allocate(character(len=0)::unnamed(0))
-endif
-
-ilongest=longest_command_argument()
-allocate(character(len=max(63,ilongest))::cmdarg)
-cmdarg(:)=''
-! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM
-do i=1,command_argument_count()
-call get_command_argument(i,cmdarg)
-if(scan(adjustl(cmdarg(1:1)),'@')==1)then
- call get_prototype(cmdarg,prototype)
-call split(prototype,array)
-! assume that if using subcommands first word not starting with dash is the subcommand
-do j=1,size(array)
-if(adjustl(array(j)(1:1))/='-')then
-G_subcommand=trim(array(j))
-sub=G_subcommand
-exit
- endif
- enddo
- endif
- enddo
-
- if(G_subcommand/='')then
-sub=G_subcommand
-elseif(size(unnamed)/=0)then
-sub=unnamed(1)
-else
-cmdarg(:)=''
-do i=1,command_argument_count()
-call get_command_argument(i,cmdarg)
-if(adjustl(cmdarg(1:1))/='-')then
-sub=trim(cmdarg)
-exit
- endif
- enddo
- endif
-G_options_only=.false.
-end function get_subcommand
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!===================================================================================================================================
-subroutine set_usage(keyword,description,value)
-character(len=*),intent(in)::keyword
-character(len=*),intent(in)::description
-character(len=*),intent(in)::value
-write(*,*)keyword
-write(*,*)description
-write(*,*)value
-! store the descriptions in an array and then apply them when set_args(3f) is called.
-! alternatively, could allow for a value as well in lieu of the prototype
-end subroutine set_usage
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command
-!! and store tokens into dictionary
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! recursive subroutine prototype_to_dictionary(string)
-!!
-!! character(len=*),intent(in) :: string
-!!
-!!##DESCRIPTION
-!! given a string of form
-!!
-!! -var value -var value
-!!
-!! define dictionary of form
+debug_mode=upper(get_env('CLI_DEBUG_MODE','FALSE'))//' '
+select case(debug_mode(1:1))
+case('Y','T')
+G_DEBUG=.true.
+end select
+
+G_response=CLI_RESPONSE_FILE
+G_options_only=.false.
+G_passed_in=''
+G_STOP=0
+G_STOP_MESSAGE=''
+if(present(prefix))then
+G_PREFIX=prefix
+else
+G_PREFIX=''
+endif
+ if(present(ierr))then
+G_QUIET=.true.
+else
+G_QUIET=.false.
+endif
+ibig=longest_command_argument()! bug in gfortran. len=0 should be fine
+IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED)
+ALLOCATE(CHARACTER(LEN=IBIG)::UNNAMED(0))
+if(allocated(args))deallocate(args)
+allocate(character(len=ibig)::args(0))
+
+call wipe_dictionary()
+hold='--version F --usage F --help F --version F '//adjustl(prototype)
+call prototype_and_cmd_args_to_nlist(hold,string)
+if(allocated(G_RESPONSE_IGNORED))then
+ if(G_DEBUG)write(*,gen)'<DEBUG>SET_ARGS:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED
+if(size(unnamed)/=0)write(*,*)'LOGIC ERROR'
+call split(G_RESPONSE_IGNORED,unnamed)
+endif
+
+ if(.not.allocated(unnamed))then
+ allocate(character(len=0)::unnamed(0))
+endif
+ if(.not.allocated(args))then
+ allocate(character(len=0)::args(0))
+endif
+ call check_commandline(help_text,version_text)! process --help, --version, --usage
+if(present(ierr))then
+ierr=G_STOP
+endif
+ if(present(errmsg))then
+errmsg=G_STOP_MESSAGE
+endif
+end subroutine set_args
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for
+!! handling subcommands on a command line
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! function get_subcommand()
+!!
+!! character(len=:),allocatable :: get_subcommand
+!!
+!!##DESCRIPTION
+!! In the special case when creating a program with subcommands it
+!! is assumed the first word on the command line is the subcommand. A
+!! routine is required to handle response file processing, therefore
+!! this routine (optionally processing response files) returns that
+!! first word as the subcommand name.
+!!
+!! It should not be used by programs not building a more elaborate
+!! command with subcommands.
+!!
+!!##RETURNS
+!! NAME name of subcommand
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_get_subcommand
+!! !x! SUBCOMMANDS
+!! !x! For a command with subcommands like git(1)
+!! !x! you can make separate namelists for each subcommand.
+!! !x! You can call this program which has two subcommands (run, test),
+!! !x! like this:
+!! !x! demo_get_subcommand --help
+!! !x! demo_get_subcommand run -x -y -z --title -l -L
+!! !x! demo_get_subcommand test --title -l -L --testname
+!! !x! demo_get_subcommand run --help
+!! implicit none
+!! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
+!! real :: x=-999.0,y=-999.0,z=-999.0
+!! character(len=80) :: title="not set"
+!! logical :: l=.false.
+!! logical :: l_=.false.
+!! character(len=80) :: testname="not set"
+!! character(len=20) :: name
+!! call parse(name) !x! DEFINE AND PARSE COMMAND LINE
+!! !x! ALL DONE CRACKING THE COMMAND LINE.
+!! !x! USE THE VALUES IN YOUR PROGRAM.
+!! write(*,*)'command was ',name
+!! write(*,*)'x,y,z .... ',x,y,z
+!! write(*,*)'title .... ',title
+!! write(*,*)'l,l_ ..... ',l,l_
+!! write(*,*)'testname . ',testname
+!! contains
+!! subroutine parse(name)
+!! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
+!! use M_CLI2, only : set_args, get_args, get_args_fixed_length
+!! use M_CLI2, only : get_subcommand, set_mode
+!! character(len=*) :: name ! the subcommand name
+!! character(len=:),allocatable :: help_text(:), version_text(:)
+!! call set_mode('response_file')
+!! ! define version text
+!! version_text=[character(len=80) :: &
+!! '@(#)PROGRAM: demo_get_subcommand >', &
+!! '@(#)DESCRIPTION: My demo program >', &
+!! '@(#)VERSION: 1.0 20200715 >', &
+!! '@(#)AUTHOR: me, myself, and I>', &
+!! '@(#)LICENSE: Public Domain >', &
+!! '' ]
+!! ! general help for "demo_get_subcommand --help"
+!! help_text=[character(len=80) :: &
+!! ' allowed subcommands are ', &
+!! ' * run -l -L --title -x -y -z ', &
+!! ' * test -l -L --title ', &
+!! '' ]
+!! ! find the subcommand name by looking for first word on command
+!! ! not starting with dash
+!! name = get_subcommand()
+!! select case(name)
+!! case('run')
+!! help_text=[character(len=80) :: &
+!! ' ', &
+!! ' Help for subcommand "run" ', &
+!! ' ', &
+!! '' ]
+!! call set_args( &
+!! & '-x 1 -y 2 -z 3 --title "my title" -l F -L F',&
+!! & help_text,version_text)
+!! call get_args('x',x)
+!! call get_args('y',y)
+!! call get_args('z',z)
+!! call get_args_fixed_length('title',title)
+!! call get_args('l',l)
+!! call get_args('L',l_)
+!! case('test')
+!! help_text=[character(len=80) :: &
+!! ' ', &
+!! ' Help for subcommand "test" ', &
+!! ' ', &
+!! '' ]
+!! call set_args(&
+!! & '--title "my title" -l F -L F --testname "Test"',&
+!! & help_text,version_text)
+!! call get_args_fixed_length('title',title)
+!! call get_args('l',l)
+!! call get_args('L',l_)
+!! call get_args_fixed_length('testname',testname)
+!! case default
+!! ! process help and version
+!! call set_args(' ',help_text,version_text)
+!! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']'
+!! write(*,'(a)')[character(len=80) :: &
+!! ' allowed subcommands are ', &
+!! ' * run -l -L -title -x -y -z ', &
+!! ' * test -l -L -title ', &
+!! '' ]
+!! stop
+!! end select
+!! end subroutine parse
+!! end program demo_get_subcommand
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+function get_subcommand()result(sub)
+
+! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"
+
+character(len=:),allocatable::sub
+character(len=:),allocatable::cmdarg
+character(len=:),allocatable::array(:)
+character(len=:),allocatable::prototype
+integer::ilongest
+integer::i
+integer::j
+G_subcommand=''
+G_options_only=.true.
+sub=''
+
+if(.not.allocated(unnamed))then
+ allocate(character(len=0)::unnamed(0))
+endif
+
+ilongest=longest_command_argument()
+allocate(character(len=max(63,ilongest))::cmdarg)
+cmdarg(:)=''
+! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM
+do i=1,command_argument_count()
+call get_command_argument(i,cmdarg)
+if(scan(adjustl(cmdarg(1:1)),'@')==1)then
+ call get_prototype(cmdarg,prototype)
+call split(prototype,array)
+! assume that if using subcommands first word not starting with dash is the subcommand
+do j=1,size(array)
+if(adjustl(array(j)(1:1))/='-')then
+G_subcommand=trim(array(j))
+sub=G_subcommand
+exit
+ endif
+ enddo
+ endif
+ enddo
+
+ if(G_subcommand/='')then
+sub=G_subcommand
+elseif(size(unnamed)/=0)then
+sub=unnamed(1)
+else
+cmdarg(:)=''
+do i=1,command_argument_count()
+call get_command_argument(i,cmdarg)
+if(adjustl(cmdarg(1:1))/='-')then
+sub=trim(cmdarg)
+exit
+ endif
+ enddo
+ endif
+G_options_only=.false.
+end function get_subcommand
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description
+!! for keywords for the --usage switch
+!! (LICENSE:PD)!!
-!! keyword(i), value(i)
+!!##SYNOPSIS!!
-!! o string values
+!! subroutine set_usage(keyword,description)!!
-!! o must be delimited with double quotes.
-!! o adjacent double quotes put one double quote into value
-!! o must not be null. A blank is specified as " ", not "".
-!!
-!! o logical values
-!!
-!! o logical values must have a value
-!!
-!! o leading and trailing blanks are removed from unquoted values
+!! character(len=*),intent(in) :: keyword
+!! character(len=*),intent(in) :: description
+!!
+!!##DESCRIPTION
+!!
+!!##OPTIONS
+!! KEYWORD the name of a command keyword
+!! DESCRIPTION a brief one-line description of the keyword
+!!!!
-!!
-!!##OPTIONS
-!! STRING string is character input string to define command
+!!##EXAMPLE
+!!
+!! sample program:!!
-!!##RETURNS
+!! Results:!!
-!!##EXAMPLE
-!!
-!! sample program:
-!!
-!! Results:
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-recursive subroutine prototype_to_dictionary(string)
-
-! ident_4="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary"
-
-character(len=*),intent(in)::string! string is character input string of options and values
-
-character(len=:),allocatable::dummy! working copy of string
-character(len=:),allocatable::value
-character(len=:),allocatable::keyword
-character(len=3)::delmt! flag if in a delimited string or not
-character(len=1)::currnt! current character being processed
-character(len=1)::prev! character to left of CURRNT
-character(len=1)::forwrd! character to right of CURRNT
-integer,dimension(2)::ipnt
-integer::islen! number of characters in input string
-integer::ipoint
-integer::itype
-integer,parameter::VAL=1,KEYW=2
-integer::ifwd
-integer::ibegin
-integer::iend
-integer::place
-
-islen=len_trim(string)! find number of characters in input string
-if(islen==0)then! if input string is blank, even default variable will not be changed
-return
- endif
-dummy=adjustl(string)//' '
-
-keyword=""! initial variable name
-value=""! initial value of a string
-ipoint=0! ipoint is the current character pointer for (dummy)
-ipnt(2)=2! pointer to position in keyword
-ipnt(1)=1! pointer to position in value
-itype=VAL! itype=1 for value, itype=2 for variable
-
-delmt="off"
-prev=" "
-
-G_keyword_single_letter=.true.
-do
-ipoint=ipoint+1! move current character pointer forward
-currnt=dummy(ipoint:ipoint)! store current character into currnt
-ifwd=min(ipoint+1,islen)! ensure not past end of string
-forwrd=dummy(ifwd:ifwd)! next character (or duplicate if last)
-
-if((currnt=="-".and.prev==" ".and.delmt=="off".and.index("0123456789.",forwrd)==0).or.ipoint>islen)then
-! beginning of a keyword
-if(forwrd=='-')then! change --var to -var so "long" syntax is supported
-!x!dummy(ifwd:ifwd)='_'
-ipoint=ipoint+1! ignore second - instead (was changing it to _)
-G_keyword_single_letter=.false.! flag this is a long keyword
-else
-G_keyword_single_letter=.true.! flag this is a short (single letter) keyword
-endif
- if(ipnt(1)-1>=1)then! position in value
-ibegin=1
-iend=len_trim(value(:ipnt(1)-1))
-TESTIT:do
- if(iend==0)then! len_trim returned 0, value is blank
-iend=ibegin
-exit TESTIT
-elseif(value(ibegin:ibegin)==" ")then
-ibegin=ibegin+1
-else
- exit TESTIT
-endif
- enddo TESTIT
-if(keyword/=' ')then
- call update(keyword,value)! store name and its value
-elseif(G_remaining_option_allowed)then! meaning "--" has been encountered
-call update('_args_',trim(value))
-else
-!x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword)
-G_RESPONSE_IGNORED=TRIM(VALUE)
-if(G_DEBUG)write(*,gen)'<DEBUG>PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED
-endif
- else
- call locate_key(keyword,place)
-if(keyword/=' '.and.place<0)then
- call update(keyword,'F')! store name and null value (first pass)
-elseif(keyword/=' ')then
- call update(keyword,' ')! store name and null value (second pass)
-elseif(.not.G_keyword_single_letter.and.ipoint-2==islen)then! -- at end of line
-G_remaining_option_allowed=.true.! meaning for "--" is that everything on commandline goes into G_remaining
-endif
- endif
-itype=KEYW! change to expecting a keyword
-value=""! clear value for this variable
-keyword=""! clear variable name
-ipnt(1)=1! restart variable value
-ipnt(2)=1! restart variable name
-
-else! currnt is not one of the special characters
-! the space after a keyword before the value
-if(currnt==" ".and.itype==KEYW)then
-! switch from building a keyword string to building a value string
-itype=VAL
-! beginning of a delimited value
-elseif(currnt=="""".and.itype==VAL)then
-! second of a double quote, put quote in
-if(prev=="""")then
- if(itype==VAL)then
- value=value//currnt
-else
-keyword=keyword//currnt
-endif
-ipnt(itype)=ipnt(itype)+1
-delmt="on"
-elseif(delmt=="on")then! first quote of a delimited string
-delmt="off"
-else
-delmt="on"
-endif
- if(prev/="""")then! leave quotes where found them
-if(itype==VAL)then
- value=value//currnt
-else
-keyword=keyword//currnt
-endif
-ipnt(itype)=ipnt(itype)+1
-endif
- else! add character to current keyword or value
-if(itype==VAL)then
- value=value//currnt
-else
-keyword=keyword//currnt
-endif
-ipnt(itype)=ipnt(itype)+1
-endif
-
- endif
-
-prev=currnt
-if(ipoint<=islen)then
- cycle
- else
- exit
- endif
- enddo
-
-end subroutine prototype_to_dictionary
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present
-!! on command line
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! elemental impure function specified(name)
-!!
-!! character(len=*),intent(in) :: name
-!! logical :: specified
-!!
-!!##DESCRIPTION
-!!
-!! specified(3f) returns .true. if the specified keyword was present on
-!! the command line.
-!!
-!!##OPTIONS
-!!
-!! NAME name of commandline argument to query the presence of
-!!
-!!##RETURNS
-!! SPECIFIED returns .TRUE. if specified NAME was present on the command
-!! line when the program was invoked.
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_specified
-!! use M_CLI2, only : set_args, get_args, specified
-!! implicit none
-!! ! DEFINE ARGS
-!! integer :: flag
-!! integer,allocatable :: ints(:)
-!! real,allocatable :: two_names(:)
-!!
-!! ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED
-!! ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM
-!! call set_args('&
-!! & --flag 1 -f 1 &
-!! & --ints 1,2,3 -i 1,2,3 &
-!! & --two_names 11.3 -T 11.3')
-!!
-!! ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME
-!! call get_args('flag',flag)
-!! if(specified('f'))call get_args('f',flag)
-!! call get_args('ints',ints)
-!! if(specified('i'))call get_args('i',ints)
-!! call get_args('two_names',two_names)
-!! if(specified('T'))call get_args('T',two_names)
-!!
-!! ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE
-!! ! ANY(3f) and ALL(3f)
-!! write(*,*)specified(['two_names','T '])
-!! write(*,*)'ANY:',any(specified(['two_names','T ']))
-!! write(*,*)'ALL:',all(specified(['two_names','T ']))
-!!
-!! ! FOR MUTUALLY EXCLUSIVE
-!! if (all(specified(['two_names','T '])))then
-!! write(*,*)'You specified both names -T and -two_names'
-!! endif
-!!
-!! ! FOR REQUIRED PARAMETER
-!! if (.not.any(specified(['two_names','T '])))then
-!! write(*,*)'You must specify -T or -two_names'
-!! endif
-!! ! USE VALUES
-!! write(*,*)'flag=',flag
-!! write(*,*)'ints=',ints
-!! write(*,*)'two_names=',two_names
-!! end program demo_specified
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-elemental impure function specified(key)
-character(len=*),intent(in)::key
-logical::specified
-integer::place
-call locate_key(key,place)! find where string is or should be
-if(place<1)then
-specified=.false.
-else
-specified=present_in(place)
-endif
-end function specified
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given
-!! keyword and value
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine update(key,val)
-!!
-!! character(len=*),intent(in) :: key
-!! character(len=*),intent(in),optional :: val
-!!##DESCRIPTION
-!! Update internal dictionary in M_CLI2(3fm) module.
-!!##OPTIONS
-!! key name of keyword to add, replace, or delete from dictionary
-!! val if present add or replace value associated with keyword. If not
-!! present remove keyword entry from dictionary.
-!!
-!! If "present" is true, a value will be appended
-!!##EXAMPLE
-!!
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-subroutine update(key,val)
-character(len=*),intent(in)::key
-character(len=*),intent(in),optional::val
-integer::place,ii
-integer::iilen
-character(len=:),allocatable::val_local
-character(len=:),allocatable::short
-character(len=:),allocatable::long
-character(len=:),allocatable::long_short(:)
-integer::isize
-logical::set_mandatory
-set_mandatory=.false.
-call split(trim(key),long_short,':',nulls='return')! split long:short keyname or long:short:: or long:: or short::
-! check for :: on end
-isize=size(long_short)
-
-if(isize>0)then! very special-purpose syntax where if ends in :: next field is a value even
-if(long_short(isize)=='')then! if it starts with a dash, for --flags option on fpm(1).
-set_mandatory=.true.
-long_short=long_short(:isize-1)
-endif
- endif
-
- select case(size(long_short))
-case(0)
-long=''
-short=''
-case(1)
-long=trim(long_short(1))
-if(len_trim(long)==1)then
-!x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value
-ii=maxloc([0,merge(1,0,shorts==long)],dim=1)
-if(ii>1)then
-long=keywords(ii-1)
-endif
-short=long
-else
-short=''
-endif
- case(2)
-long=trim(long_short(1))
-short=trim(long_short(2))
-case default
-write(warn,*)'WARNING: incorrect syntax for key: ',trim(key)
-long=trim(long_short(1))
-short=trim(long_short(2))
-end select
- if(G_UNDERDASH)then
-long=replace_str(long,'-','_')
-endif
- if(G_IGNORECASE.and.len(long)>1)long=lower(long)
-if(present(val))then
-val_local=val
-iilen=len_trim(val_local)
-call locate_key(long,place)! find where string is or should be
-if(place<1)then! if string was not found insert it
-call insert_(keywords,long,iabs(place))
-call insert_(values,val_local,iabs(place))
-call insert_(counts,iilen,iabs(place))
-call insert_(shorts,short,iabs(place))
-call insert_(present_in,.true.,iabs(place))
-call insert_(mandatory,set_mandatory,iabs(place))
-else
- if(present_in(place))then! if multiple keywords append values with space between them
-if(G_append)then
- if(values(place)(1:1)=='"')then
-! UNDESIRABLE: will ignore previous blank entries
-val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"'
-else
-val_local=values(place)//' '//val_local
-endif
- endif
-iilen=len_trim(val_local)
-endif
- call replace_(values,val_local,place)
-call replace_(counts,iilen,place)
-call replace_(present_in,.true.,place)
-endif
- else! if no value is present remove the keyword and related values
-call locate_key(long,place)! check name as long and short
-if(place>0)then
- call remove_(keywords,place)
-call remove_(values,place)
-call remove_(counts,place)
-call remove_(shorts,place)
-call remove_(present_in,place)
-call remove_(mandatory,place)
-endif
- endif
-end subroutine update
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm)
-!! dictionary to empty
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine wipe_dictionary()
-!!##DESCRIPTION
-!! reset private M_CLI2(3fm) dictionary to empty
-!!##EXAMPLE
-!!
-!! Sample program:
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine set_usage(keyword,description,value)
+character(len=*),intent(in)::keyword
+character(len=*),intent(in)::description
+character(len=*),intent(in)::value
+write(*,*)keyword
+write(*,*)description
+write(*,*)value
+! store the descriptions in an array and then apply them when set_args(3f) is called.
+! alternatively, could allow for a value as well in lieu of the prototype
+end subroutine set_usage
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command
+!! and store tokens into dictionary
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! recursive subroutine prototype_to_dictionary(string)
+!!
+!! character(len=*),intent(in) :: string
+!!
+!!##DESCRIPTION
+!! given a string of form
+!!
+!! -var value -var value
+!!
+!! define dictionary of form
+!!
+!! keyword(i), value(i)
+!!
+!! o string values
+!!
+!! o must be delimited with double quotes.
+!! o adjacent double quotes put one double quote into value
+!! o must not be null. A blank is specified as " ", not "".
+!!
+!! o logical values
+!!
+!! o logical values must have a value. Use F.
+!!
+!! o leading and trailing blanks are removed from unquoted values
+!!
+!!
+!!##OPTIONS
+!! STRING string is character input string to define command
+!!
+!!##RETURNS
+!!
+!!##EXAMPLE
+!!
+!! sample program:
+!!
+!! call prototype_to_dictionary(' -l F --ignorecase F --title "my title string" -x 10.20')
+!! call prototype_to_dictionary(' --ints 1,2,3,4')
+!!
+!! Results:
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+recursive subroutine prototype_to_dictionary(string)
+
+! ident_3="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary"
+
+character(len=*),intent(in)::string! string is character input string of options and values
+
+character(len=:),allocatable::dummy! working copy of string
+character(len=:),allocatable::value
+character(len=:),allocatable::keyword
+character(len=3)::delmt! flag if in a delimited string or not
+character(len=1)::currnt! current character being processed
+character(len=1)::prev! character to left of CURRNT
+character(len=1)::forwrd! character to right of CURRNT
+integer,dimension(2)::ipnt
+integer::islen! number of characters in input string
+integer::ipoint
+integer::itype
+integer,parameter::VAL=1,KEYW=2
+integer::ifwd
+integer::ibegin
+integer::iend
+integer::place
+
+islen=len_trim(string)! find number of characters in input string
+if(islen==0)then! if input string is blank, even default variable will not be changed
+return
+ endif
+dummy=adjustl(string)//' '
+
+keyword=""! initial variable name
+value=""! initial value of a string
+ipoint=0! ipoint is the current character pointer for (dummy)
+ipnt(2)=2! pointer to position in keyword
+ipnt(1)=1! pointer to position in value
+itype=VAL! itype=1 for value, itype=2 for variable
+
+delmt="off"
+prev=" "
+
+G_keyword_single_letter=.true.
+do
+ipoint=ipoint+1! move current character pointer forward
+currnt=dummy(ipoint:ipoint)! store current character into currnt
+ifwd=min(ipoint+1,islen)! ensure not past end of string
+forwrd=dummy(ifwd:ifwd)! next character (or duplicate if last)
+
+if((currnt=="-".and.prev==" ".and.delmt=="off".and.index("0123456789.",forwrd)==0).or.ipoint>islen)then
+! beginning of a keyword
+if(forwrd=='-')then! change --var to -var so "long" syntax is supported
+!x!dummy(ifwd:ifwd)='_'
+ipoint=ipoint+1! ignore second - instead (was changing it to _)
+G_keyword_single_letter=.false.! flag this is a long keyword
+else
+G_keyword_single_letter=.true.! flag this is a short (single letter) keyword
+endif
+ if(ipnt(1)-1>=1)then! position in value
+ibegin=1
+iend=len_trim(value(:ipnt(1)-1))
+TESTIT:do
+ if(iend==0)then! len_trim returned 0, value is blank
+iend=ibegin
+exit TESTIT
+elseif(value(ibegin:ibegin)==" ")then
+ibegin=ibegin+1
+else
+ exit TESTIT
+endif
+ enddo TESTIT
+if(keyword/=' ')then
+ if(value=='[]')value=','
+call update(keyword,value)! store name and its value
+elseif(G_remaining_option_allowed)then! meaning "--" has been encountered
+if(value=='[]')value=','
+call update('_args_',trim(value))
+else
+!x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword)
+G_RESPONSE_IGNORED=TRIM(VALUE)
+if(G_DEBUG)write(*,gen)'<DEBUG>PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:',G_RESPONSE_IGNORED
+endif
+ else
+ call locate_key(keyword,place)
+if(keyword/=' '.and.place<0)then
+ call update(keyword,'F')! store name and null value (first pass)
+elseif(keyword/=' ')then
+ call update(keyword,' ')! store name and null value (second pass)
+elseif(.not.G_keyword_single_letter.and.ipoint-2==islen)then! -- at end of line
+G_remaining_option_allowed=.true.! meaning for "--" is that everything on commandline goes into G_remaining
+endif
+ endif
+itype=KEYW! change to expecting a keyword
+value=""! clear value for this variable
+keyword=""! clear variable name
+ipnt(1)=1! restart variable value
+ipnt(2)=1! restart variable name
+
+else! currnt is not one of the special characters
+! the space after a keyword before the value
+if(currnt==" ".and.itype==KEYW)then
+! switch from building a keyword string to building a value string
+itype=VAL
+! beginning of a delimited value
+elseif(currnt=="""".and.itype==VAL)then
+! second of a double quote, put quote in
+if(prev=="""")then
+ if(itype==VAL)then
+ value=value//currnt
+else
+keyword=keyword//currnt
+endif
+ipnt(itype)=ipnt(itype)+1
+delmt="on"
+elseif(delmt=="on")then! first quote of a delimited string
+delmt="off"
+else
+delmt="on"
+endif
+ if(prev/="""")then! leave quotes where found them
+if(itype==VAL)then
+ value=value//currnt
+else
+keyword=keyword//currnt
+endif
+ipnt(itype)=ipnt(itype)+1
+endif
+ else! add character to current keyword or value
+if(itype==VAL)then
+ value=value//currnt
+else
+keyword=keyword//currnt
+endif
+ipnt(itype)=ipnt(itype)+1
+endif
+
+ endif
+
+prev=currnt
+if(ipoint<=islen)then
+ cycle
+ else
+ exit
+ endif
+ enddo
+
+end subroutine prototype_to_dictionary
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present
+!! on command line
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! elemental impure function specified(name)
+!!
+!! character(len=*),intent(in) :: name
+!! logical :: specified
+!!
+!!##DESCRIPTION
+!!
+!! specified(3f) returns .true. if the specified keyword was present on
+!! the command line.
+!!
+!! M_CLI2 intentionally does not have validators except for SPECIFIED(3f)
+!! and of course a check whether the input conforms to the type when
+!! requesting a value (with get_args(3f) or the convenience functions
+!! like inum(3f)).
+!!
+!! Fortran already has powerful validation capabilities. Logical
+!! expressions ANY(3f) and ALL(3f) are standard Fortran features which
+!! easily allow performing the common validations for command line
+!! arguments without having to learn any additional syntax or methods.
+!!
+!!##OPTIONS
+!!
+!! NAME name of commandline argument to query the presence of. Long
+!! names should always be used.
+!!
+!!##RETURNS
+!! SPECIFIED returns .TRUE. if specified NAME was present on the command
+!! line when the program was invoked.
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_specified
+!! use, intrinsic :: iso_fortran_env, only : &
+!! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
+!! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget
+!! implicit none
+!!
+!! ! Define args
+!! integer,allocatable :: ints(:)
+!! real,allocatable :: floats(:)
+!! logical :: flag
+!! character(len=:),allocatable :: color
+!! character(len=:),allocatable :: list(:)
+!! integer :: i
+!!
+!! call set_args('&
+!! & --color:c "red" &
+!! & --flag:f F &
+!! & --ints:i 1,10,11 &
+!! & --floats:T 12.3, 4.56 &
+!! & ')
+!! ints=igets('ints')
+!! floats=rgets('floats')
+!! flag=lget('flag')
+!! color=sget('color')
+!!
+!! write(*,*)'color=',color
+!! write(*,*)'flag=',flag
+!! write(*,*)'ints=',ints
+!! write(*,*)'floats=',floats
+!!
+!! write(*,*)'was -flag specified?',specified('flag')
+!!
+!! ! elemental
+!! write(*,*)specified(['floats','ints '])
+!!
+!! ! If you want to know if groups of parameters were specified use
+!! ! ANY(3f) and ALL(3f)
+!! write(*,*)'ANY:',any(specified(['floats','ints ']))
+!! write(*,*)'ALL:',all(specified(['floats','ints ']))
+!!
+!! ! For mutually exclusive
+!! if (all(specified(['floats','ints '])))then
+!! write(*,*)'You specified both names --ints and --floats'
+!! endif
+!!
+!! ! For required parameter
+!! if (.not.any(specified(['floats','ints '])))then
+!! write(*,*)'You must specify --ints or --floats'
+!! endif
+!!
+!! ! check if all values are in range from 10 to 30 and even
+!! write(*,*)'are all numbers good?',all([ints >= 10,ints <= 30,(ints/2)*2 == ints])
+!!
+!! ! perhaps you want to check one value at a time
+!! do i=1,size(ints)
+!! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]
+!! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then
+!! write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+!! else
+!! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+!! endif
+!! enddo
+!!
+!! list = [character(len=10) :: 'red','white','blue']
+!! if( any(color == list) )then
+!! write(*,*)color,'matches a value in the list'
+!! else
+!! write(*,*)color,'not in the list'
+!! endif
+!!
+!! if(size(ints).eq.3)then
+!! write(*,*)'ints(:) has expected number of values'
+!! else
+!! write(*,*)'ints(:) does not have expected number of values'
+!! endif
+!!
+!! end program demo_specified
+!!
+!! Default output
+!!
+!! > color=red
+!! > flag= F
+!! > ints= 1 10 11
+!! > floats= 12.3000002 4.55999994
+!! > was -flag specified? F
+!! > F F
+!! > ANY: F
+!! > ALL: F
+!! > You must specify --ints or --floats
+!! > 1 F T F
+!! > 1 is not an even number from 10 to 30 inclusive
+!! > 10 T T T
+!! > 10 is an even number from 10 to 30 inclusive
+!! > 11 T T F
+!! > 11 is not an even number from 10 to 30 inclusive
+!! > red matches a value in the list
+!! > ints(:) has expected number of values
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+elemental impure function specified(key)
+character(len=*),intent(in)::key
+logical::specified
+integer::place
+call locate_key(key,place)! find where string is or should be
+if(place<1)then
+specified=.false.
+else
+specified=present_in(place)
+endif
+end function specified
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given
+!! keyword and value
+!! (LICENSE:PD)
+!!##SYNOPSIS!!
-!! program demo_wipe_dictionary
-!! use M_CLI2, only : dictionary
-!! call wipe_dictionary()
-!! end program demo_wipe_dictionary
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-subroutine wipe_dictionary()
-if(allocated(keywords))deallocate(keywords)
-allocate(character(len=0)::keywords(0))
-if(allocated(values))deallocate(values)
-allocate(character(len=0)::values(0))
-if(allocated(counts))deallocate(counts)
-allocate(counts(0))
-if(allocated(shorts))deallocate(shorts)
-allocate(character(len=0)::shorts(0))
-if(allocated(present_in))deallocate(present_in)
-allocate(present_in(0))
-if(allocated(mandatory))deallocate(mandatory)
-allocate(mandatory(0))
-end subroutine wipe_dictionary
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with
-!! key name in private M_CLI2(3fm) dictionary
-!!##SYNOPSIS
-!!
-!!
-!!##DESCRIPTION
-!! Get dictionary value associated with key name in private M_CLI2(3fm)
-!! dictionary.
-!!##OPTIONS
-!!##RETURNS
-!!##EXAMPLE
-!!
-!===================================================================================================================================
-function get(key)result(valout)
-character(len=*),intent(in)::key
-character(len=:),allocatable::valout
-integer::place
-! find where string is or should be
-call locate_key(key,place)
-if(place<1)then
-valout=''
-else
-valout=values(place)(:counts(place))
-endif
-end function get
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert
-!! Unix-like command arguments to table
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine prototype_and_cmd_args_to_nlist(prototype)
-!!
-!! character(len=*) :: prototype
-!!##DESCRIPTION
-!! create dictionary with character keywords, values, and value lengths
-!! using the routines for maintaining a list from command line arguments.
-!!##OPTIONS
-!! prototype
-!!##EXAMPLE
-!!
-!! Sample program
-!!
-!! program demo_prototype_and_cmd_args_to_nlist
-!! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed
-!! implicit none
-!! character(len=:),allocatable :: readme
-!! character(len=256) :: message
-!! integer :: ios
-!! integer :: i
-!! doubleprecision :: something
-!!
-!! ! define arguments
-!! logical :: l,h,v
-!! real :: p(2)
-!! complex :: c
-!! doubleprecision :: x,y,z
-!!
-!! ! uppercase keywords get an underscore to make it easier o remember
-!! logical :: l_,h_,v_
-!! ! character variables must be long enough to hold returned value
-!! character(len=256) :: a_,b_
-!! integer :: c_(3)
-!!
-!! ! give command template with default values
-!! ! all values except logicals get a value.
-!! ! strings must be delimited with double quotes
-!! ! A string has to have at least one character as for -A
-!! ! lists of numbers should be comma-delimited.
-!! ! No spaces are allowed in lists of numbers
-!! call prototype_and_cmd_args_to_nlist('&
-!! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 &
-!! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme)
-!!
-!! call get_args('x',x,'y',y,'z',z)
-!! something=sqrt(x**2+y**2+z**2)
-!! write (*,*)something,x,y,z
-!! if(size(unnamed) > 0)then
-!! write (*,'(a)')'files:'
-!! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
-!! endif
-!! end program demo_prototype_and_cmd_args_to_nlist
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-subroutine prototype_and_cmd_args_to_nlist(prototype,string)
-
-! ident_5="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line"
-
-character(len=*),intent(in)::prototype
-character(len=*),intent(in),optional::string
-integer::ibig
-integer::itrim
-integer::iused
-
-if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:START'
-G_passed_in=prototype! make global copy for printing
-ibig=longest_command_argument()! bug in gfortran. len=0 should be fine
-ibig=max(ibig,1)
-IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED)
-ALLOCATE(CHARACTER(LEN=IBIG)::UNNAMED(0))
-if(allocated(args))deallocate(args)
-allocate(character(len=ibig)::args(0))
-
-G_remaining_option_allowed=.false.
-G_remaining_on=.false.
-G_remaining=''
-if(prototype/='')then
- call prototype_to_dictionary(prototype)! build dictionary from prototype
-
-! if short keywords not used by user allow them for standard options
-
-call locate_key('h',iused)
-if(iused<=0)then
- call update('help')
-call update('help:h','F')
-endif
-
- call locate_key('v',iused)
-if(iused<=0)then
- call update('version')
-call update('version:v','F')
-endif
-
- call locate_key('V',iused)
-if(iused<=0)then
- call update('verbose')
-call update('verbose:V','F')
-endif
-
- call locate_key('u',iused)
-if(iused<=0)then
- call update('usage')
-call update('usage:u','F')
-endif
-
-present_in=.false.! reset all values to false so everything gets written
-endif
-
- if(present(string))then! instead of command line arguments use another prototype string
-if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=',STRING
-call prototype_to_dictionary(string)! build dictionary from prototype
-else
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=',.true.
-call cmd_args_to_dictionary()
-endif
-
- if(len(G_remaining)>1)then! if -- was in prototype then after -- on input return rest in this string
-itrim=len(G_remaining)
-if(G_remaining(itrim:itrim)==' ')then! was adding a space at end as building it, but do not want to remove blanks
-G_remaining=G_remaining(:itrim-1)
-endif
-remaining=G_remaining
-endif
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:NORMAL END'
-end subroutine prototype_and_cmd_args_to_nlist
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-subroutine expand_response(name)
-character(len=*),intent(in)::name
-character(len=:),allocatable::prototype
-logical::hold
-
-if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:START:NAME=',name
-
-call get_prototype(name,prototype)
-
-if(prototype/='')then
-hold=G_append
-G_append=.false.
-if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=',prototype
-call prototype_to_dictionary(prototype)! build dictionary from prototype
-G_append=hold
-endif
-
- if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:END'
-
-end subroutine expand_response
-!===================================================================================================================================
-subroutine get_prototype(name,prototype)! process @name abbreviations
-character(len=*),intent(in)::name
-character(len=:),allocatable,intent(out)::prototype
-character(len=:),allocatable::filename
-character(len=:),allocatable::os
-character(len=:),allocatable::plain_name
-character(len=:),allocatable::search_for
-integer::lun
-integer::ios
-integer::itrim
-character(len=4096)::line!x! assuming input never this long
-character(len=256)::message
-character(len=:),allocatable::array(:)! output array of tokens
-integer::lines_processed
-
-lines_processed=0
-plain_name=name//' '
-plain_name=trim(name(2:))
-os='@'//get_env('OSTYPE',get_env('OS'))
-if(G_DEBUG)write(*,gen)'<DEBUG>GET_PROTOTYPE:OS=',OS
-
-search_for=''
-! look for NAME.rsp and see if there is an @OS section in it and position to it and read
-if(os/='@')then
-search_for=os
-call find_and_read_response_file(plain_name)
-if(lines_processed/=0)return
- endif
-
-! look for NAME.rsp and see if there is anything before an OS-specific section
-search_for=''
-call find_and_read_response_file(plain_name)
-if(lines_processed/=0)return
-
-! look for ARG0.rsp with @OS@NAME section in it and position to it
-if(os/='@')then
-search_for=os//name
-call find_and_read_response_file(basename(get_name(),suffix=.false.))
-if(lines_processed/=0)return
- endif
-
-! look for ARG0.rsp with a section called @NAME in it and position to it
-search_for=name
-call find_and_read_response_file(basename(get_name(),suffix=.false.))
-if(lines_processed/=0)return
-
- write(*,gen)'<ERROR> response name ['//trim(name)//'] not found'
-stop 1
-contains
-!===================================================================================================================================
-subroutine find_and_read_response_file(rname)
-! search for a simple file named the same as the @NAME field with one entry assumed in it
-character(len=*),intent(in)::rname
-character(len=:),allocatable::paths(:)
-character(len=:),allocatable::testpath
-character(len=256)::message
-integer::i
-integer::ios
-prototype=''
-! look for NAME.rsp
-! assume if have / or \ a full filename was supplied to support ifort(1)
-if((index(rname,'/')/=0.or.index(rname,'\') /= 0) .and. len(rname) > 1 )then
- filename=rname
- lun=fileopen(filename,message)
- if(lun /= -1)then
- call process_response()
- close(unit=lun,iostat=ios)
- endif
- return
- else
- filename=rname//'.rsp'
- endif
- if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:FILENAME=',filename
-
- ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories
- call split(get_env('CLI_RESPONSE_PATH','~/.local/share/rsp'),paths)
- paths=[character(len=len(paths)) :: '',paths]
- if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:PATHS=',paths
+!! subroutine update(key,val)
+!!
+!! character(len=*),intent(in) :: key
+!! character(len=*),intent(in),optional :: val
+!!##DESCRIPTION
+!! Update internal dictionary in M_CLI2(3fm) module.
+!!##OPTIONS
+!! key name of keyword to add, replace, or delete from dictionary
+!! val if present add or replace value associated with keyword. If not
+!! present remove keyword entry from dictionary.
+!!
+!! If "present" is true, a value will be appended
+!!##EXAMPLE
+!!
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine update(key,val)
+character(len=*),intent(in)::key
+character(len=*),intent(in),optional::val
+integer::place,ii
+integer::iilen
+character(len=:),allocatable::val_local
+character(len=:),allocatable::short
+character(len=:),allocatable::long
+character(len=:),allocatable::long_short(:)
+integer::isize
+logical::set_mandatory
+set_mandatory=.false.
+call split(trim(key),long_short,':',nulls='return')! split long:short keyword or long:short:: or long:: or short::
+! check for :: on end
+isize=size(long_short)
+
+if(isize>0)then! very special-purpose syntax where if ends in :: next field is a value even
+if(long_short(isize)=='')then! if it starts with a dash, for --flags option on fpm(1).
+set_mandatory=.true.
+long_short=long_short(:isize-1)
+endif
+ endif
+
+ select case(size(long_short))
+case(0)
+long=''
+short=''
+case(1)
+long=trim(long_short(1))
+if(len_trim(long)==1)then
+!x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value
+ii=maxloc([0,merge(1,0,shorts==long)],dim=1)
+if(ii>1)then
+long=keywords(ii-1)
+endif
+short=long
+else
+short=''
+endif
+ case(2)
+long=trim(long_short(1))
+short=trim(long_short(2))
+case default
+write(warn,*)'WARNING: incorrect syntax for key: ',trim(key)
+long=trim(long_short(1))
+short=trim(long_short(2))
+end select
+ if(G_UNDERDASH)long=replace_str(long,'-','_')
+if(G_NOSEPARATOR)then
+long=replace_str(long,'-','')
+long=replace_str(long,'_','')
+endif
+ if(G_IGNORECASE.and.len_trim(long)>1)long=lower(long)
+if(present(val))then
+val_local=val
+iilen=len_trim(val_local)
+call locate_key(long,place)! find where string is or should be
+if(place<1)then! if string was not found insert it
+call insert_(keywords,long,iabs(place))
+call insert_(values,val_local,iabs(place))
+call insert_(counts,iilen,iabs(place))
+call insert_(shorts,short,iabs(place))
+call insert_(present_in,.true.,iabs(place))
+call insert_(mandatory,set_mandatory,iabs(place))
+else
+ if(present_in(place))then! if multiple keywords append values with space between them
+if(G_append)then
+ if(values(place)(1:1)=='"')then
+! UNDESIRABLE: will ignore previous blank entries
+val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"'
+else
+val_local=values(place)//' '//val_local
+endif
+ endif
+iilen=len_trim(val_local)
+endif
+ call replace_(values,val_local,place)
+call replace_(counts,iilen,place)
+call replace_(present_in,.true.,place)
+endif
+ else! if no value is present remove the keyword and related values
+call locate_key(long,place)! check name as long and short
+if(place>0)then
+ call remove_(keywords,place)
+call remove_(values,place)
+call remove_(counts,place)
+call remove_(shorts,place)
+call remove_(present_in,place)
+call remove_(mandatory,place)
+endif
+ endif
+end subroutine update
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm)
+!! dictionary to empty
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! subroutine wipe_dictionary()
+!!##DESCRIPTION
+!! reset private M_CLI2(3fm) dictionary to empty
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_wipe_dictionary
+!! use M_CLI2, only : dictionary
+!! call wipe_dictionary()
+!! end program demo_wipe_dictionary
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine wipe_dictionary()
+if(allocated(keywords))deallocate(keywords)
+allocate(character(len=0)::keywords(0))
+if(allocated(values))deallocate(values)
+allocate(character(len=0)::values(0))
+if(allocated(counts))deallocate(counts)
+allocate(counts(0))
+if(allocated(shorts))deallocate(shorts)
+allocate(character(len=0)::shorts(0))
+if(allocated(present_in))deallocate(present_in)
+allocate(present_in(0))
+if(allocated(mandatory))deallocate(mandatory)
+allocate(mandatory(0))
+end subroutine wipe_dictionary
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with
+!! key name in private M_CLI2(3fm) dictionary
+!!##SYNOPSIS
+!!
+!!
+!!##DESCRIPTION
+!! Get dictionary value associated with key name in private M_CLI2(3fm)
+!! dictionary.
+!!##OPTIONS
+!!##RETURNS
+!!##EXAMPLE
+!!
+!===================================================================================================================================
+function get(key)result(valout)
+character(len=*),intent(in)::key
+character(len=:),allocatable::valout
+integer::place
+! find where string is or should be
+call locate_key(key,place)
+if(place<1)then
+valout=''
+else
+valout=values(place)(:counts(place))
+endif
+end function get
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert
+!! Unix-like command arguments to table
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! subroutine prototype_and_cmd_args_to_nlist(prototype)
+!!
+!! character(len=*) :: prototype
+!!##DESCRIPTION
+!! create dictionary with character keywords, values, and value lengths
+!! using the routines for maintaining a list from command line arguments.
+!!##OPTIONS
+!! prototype
+!!##EXAMPLE
+!!
+!! Sample program
+!!
+!! program demo_prototype_and_cmd_args_to_nlist
+!! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed
+!! implicit none
+!! character(len=:),allocatable :: readme
+!! character(len=256) :: message
+!! integer :: ios
+!! integer :: i
+!! doubleprecision :: something
+!!
+!! ! define arguments
+!! logical :: l,h,v
+!! real :: p(2)
+!! complex :: c
+!! doubleprecision :: x,y,z
+!!
+!! ! uppercase keywords get an underscore to make it easier to remember
+!! logical :: l_,h_,v_
+!! ! character variables must be long enough to hold returned value
+!! character(len=256) :: a_,b_
+!! integer :: c_(3)
+!!
+!! ! give command template with default values
+!! ! all values except logicals get a value.
+!! ! strings must be delimited with double quotes
+!! ! A string has to have at least one character as for -A
+!! ! lists of numbers should be comma-delimited.
+!! ! No spaces are allowed in lists of numbers
+!! call prototype_and_cmd_args_to_nlist('&
+!! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 &
+!! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme)
+!!
+!! call get_args('x',x,'y',y,'z',z)
+!! something=sqrt(x**2+y**2+z**2)
+!! write (*,*)something,x,y,z
+!! if(size(unnamed) > 0)then
+!! write (*,'(a)')'files:'
+!! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
+!! endif
+!! end program demo_prototype_and_cmd_args_to_nlist
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine prototype_and_cmd_args_to_nlist(prototype,string)
+
+! ident_4="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line"
+
+character(len=*),intent(in)::prototype
+character(len=*),intent(in),optional::string
+integer::ibig
+integer::itrim
+integer::iused
+
+if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:START'
+G_passed_in=prototype! make global copy for printing
+ibig=longest_command_argument()! bug in gfortran. len=0 should be fine
+ibig=max(ibig,1)
+IF(ALLOCATED(UNNAMED))DEALLOCATE(UNNAMED)
+ALLOCATE(CHARACTER(LEN=IBIG)::UNNAMED(0))
+if(allocated(args))deallocate(args)
+allocate(character(len=ibig)::args(0))
+
+G_remaining_option_allowed=.false.
+G_remaining_on=.false.
+G_remaining=''
+if(prototype/='')then
+ call prototype_to_dictionary(prototype)! build dictionary from prototype
+
+! if short keywords not used by user allow them for standard options
+
+call locate_key('h',iused)
+if(iused<=0)then
+ call update('help')
+call update('help:h','F')
+endif
+
+ call locate_key('v',iused)
+if(iused<=0)then
+ call update('version')
+call update('version:v','F')
+endif
+
+ call locate_key('V',iused)
+if(iused<=0)then
+ call update('verbose')
+call update('verbose:V','F')
+endif
- do i=1,size(paths)
- testpath=join_path(paths(i),filename)
- lun=fileopen(testpath,message)
- if(lun /= -1)then
- if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:SEARCH_FOR=',search_for
- if(search_for /= '') call position_response() ! set to end of file or where string was found
- call process_response()
- if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:LINES_PROCESSED=',LINES_PROCESSED
- close(unit=lun,iostat=ios)
- if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:CLOSE:LUN=',LUN,'IOSTAT=',IOS
- if(lines_processed /= 0)exit
- endif
- enddo
-
-end subroutine find_and_read_response_file
-!===================================================================================================================================
-subroutine position_response()
-integer :: ios
- line=''
- INFINITE: do
- read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line
- if(is_iostat_end(ios))then
- if(G_DEBUG)write(*,gen)'<DEBUG>POSITION_RESPONSE:EOF'
- backspace(lun,iostat=ios)
- exit INFINITE
- elseif(ios /= 0)then
- write(*,gen)'<ERROR>*position_response*:'//trim(message)
- exit INFINITE
- endif
- line=adjustl(line)
- if(line == search_for)return
- enddo INFINITE
-end subroutine position_response
-!===================================================================================================================================
-subroutine process_response()
-character(len=:),allocatable :: padded
-character(len=:),allocatable :: temp
- line=''
- lines_processed=0
- INFINITE: do
- read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line
- if(is_iostat_end(ios))then
- backspace(lun,iostat=ios)
- exit INFINITE
- elseif(ios /= 0)then
- write(*,gen)'<ERROR>*process_response*:'//trim(message)
- exit INFINITE
- endif
- line=trim(adjustl(line))
- temp=line
- if(index(temp//'','#') == 1)cycle
- if(temp /= '')then
-
- if(index(temp,'@') == 1.and.lines_processed /= 0)exit INFINITE
-
- call split(temp,array) ! get first word
- itrim=len_trim(array(1))+2
- temp=temp(itrim:)
-
- PROCESS: select case(lower(array(1)))
- case('comment','#','')
- case('system','!','$')
-if(G_options_only)exit PROCESS
-lines_processed=lines_processed+1
-call execute_command_line(temp)
-case('options','option','-')
-lines_processed=lines_processed+1
-prototype=prototype//' '//trim(temp)
-case('print','>','echo')
-if(G_options_only)exit PROCESS
-lines_processed=lines_processed+1
-write(*,'(a)')trim(temp)
-case('stop')
-if(G_options_only)exit PROCESS
-write(*,'(a)')trim(temp)
-stop
- case default
-if(array(1)(1:1)=='-')then
-! assume these are simply options to support ifort(1)
-! if starts with a single dash must assume a single argument
-! and rest is value to support -Dname and -Ifile option
-! which currently is not supported, so multiple short keywords
-! does not work. Just a ifort(1) test at this point, so do not document
-if(G_options_only)exit PROCESS
-padded=trim(line)//' '
-if(padded(2:2)=='-')then
-prototype=prototype//' '//trim(line)
-else
-prototype=prototype//' '//padded(1:2)//' '//trim(padded(3:))
-endif
-lines_processed=lines_processed+1
-else
- if(array(1)(1:1)=='@')cycle INFINITE!skip adjacent @ lines from first
-lines_processed=lines_processed+1
-write(*,'(*(g0))')'unknown response keyword [',array(1),'] with options of [',trim(temp),']'
-endif
- end select PROCESS
-
-endif
- enddo INFINITE
-end subroutine process_response
-
-end subroutine get_prototype
-!===================================================================================================================================
-function fileopen(filename,message)result(lun)
-character(len=*),intent(in)::filename
-character(len=*),intent(out),optional::message
-integer::lun
-integer::ios
-character(len=256)::message_local
-
-ios=0
-message_local=''
-open(file=filename,newunit=lun,&
-&form='formatted',access='sequential',action='read',&
-&position='rewind',status='old',iostat=ios,iomsg=message_local)
-
-if(ios/=0)then
-lun=-1
-if(present(message))then
-message=trim(message_local)
-else
- write(*,gen)trim(message_local)
-endif
- endif
- if(G_DEBUG)write(*,gen)'<DEBUG>FILEOPEN:FILENAME=',filename,' LUN=',lun,' IOS=',IOS,' MESSAGE=',trim(message_local)
-
-end function fileopen
-!===================================================================================================================================
-function get_env(NAME,DEFAULT)result(VALUE)
-character(len=*),intent(in)::NAME
-character(len=*),intent(in),optional::DEFAULT
-character(len=:),allocatable::VALUE
-integer::howbig
-integer::stat
-integer::length
-! get length required to hold value
-length=0
-if(NAME/='')then
- call get_environment_variable(NAME,length=howbig,status=stat,trim_name=.true.)
-select case(stat)
-case(1)
-!x!print *, NAME, " is not defined in the environment. Strange..."
-VALUE=''
-case(2)
-!x!print *, "This processor doesn't support environment variables. Boooh!"
-VALUE=''
-case default
-! make string to hold value of sufficient size
-if(allocated(value))deallocate(value)
-allocate(character(len=max(howbig,1))::VALUE)
-! get value
-call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.)
-if(stat/=0)VALUE=''
-end select
- else
- VALUE=''
-endif
- if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT
-end function get_env
-!===================================================================================================================================
-function join_path(a1,a2,a3,a4,a5)result(path)
-! Construct path by joining strings with os file separator
-!
-character(len=*),intent(in)::a1,a2
-character(len=*),intent(in),optional::a3,a4,a5
-character(len=:),allocatable::path
-character(len=1)::filesep
-
-filesep=separator()
-if(a1/='')then
-path=trim(a1)//filesep//trim(a2)
-else
-path=trim(a2)
-endif
- if(present(a3))path=path//filesep//trim(a3)
-if(present(a4))path=path//filesep//trim(a4)
-if(present(a5))path=path//filesep//trim(a5)
-path=adjustl(path//' ')
-call substitute(path,filesep//filesep,'',start=2)! some systems allow names starting with '//' or '\\'
-path=trim(path)
-end function join_path
-!===================================================================================================================================
-function get_name()result(name)
-! get the pathname of arg0
-character(len=:),allocatable::arg0
-integer::arg0_length
-integer::istat
-character(len=4096)::long_name
-character(len=:),allocatable::name
-arg0_length=0
-name=''
-long_name=''
-call get_command_argument(0,length=arg0_length,status=istat)
-if(istat==0)then
- if(allocated(arg0))deallocate(arg0)
-allocate(character(len=arg0_length)::arg0)
-call get_command_argument(0,arg0,status=istat)
-if(istat==0)then
- inquire(file=arg0,iostat=istat,name=long_name)
-name=trim(long_name)
-else
-name=arg0
-endif
- endif
-end function get_name
-!===================================================================================================================================
-function basename(path,suffix)result(base)
-! Extract filename from path with/without suffix
-!
-character(*),intent(In)::path
-logical,intent(in),optional::suffix
-character(:),allocatable::base
-
-character(:),allocatable::file_parts(:)
-logical::with_suffix
-
-if(.not.present(suffix))then
-with_suffix=.true.
-else
-with_suffix=suffix
-endif
-
- if(with_suffix)then
- call split(path,file_parts,delimiters='\/')
-if(size(file_parts)>0)then
-base=trim(file_parts(size(file_parts)))
-else
-base=''
-endif
- else
- call split(path,file_parts,delimiters='\/.')
-if(size(file_parts)>=2)then
-base=trim(file_parts(size(file_parts)-1))
-elseif(size(file_parts)==1)then
-base=trim(file_parts(1))
-else
-base=''
-endif
- endif
-end function basename
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function separator()result(sep)
-!>
-!!##NAME
-!! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function separator() result(sep)
-!!
-!! character(len=1) :: sep
-!!
-!!##DESCRIPTION
-!! First testing for the existence of "/.", then if that fails a list
-!! of variable names assumed to contain directory paths {PATH|HOME} are
-!! examined first for a backslash, then a slash. Assuming basically the
-!! choice is a ULS or MSWindows system, and users can do weird things like
-!! put a backslash in a ULS path and break it.
-!!
-!! Therefore can be very system dependent. If the queries fail the
-!! default returned is "/".
-!!
-!!##EXAMPLE
-!!
-!! sample usage
-!!
-!! program demo_separator
-!! use M_io, only : separator
-!! implicit none
-!! write(*,*)'separator=',separator()
-!! end program demo_separator
-
-! use the pathname returned as arg0 to determine pathname separator
-integer::ios
-integer::i
-logical::existing=.false.
-character(len=1)::sep
-!x!IFORT BUG:character(len=1),save :: sep_cache=' '
-integer,save::isep=-1
-character(len=4096)::name
-character(len=:),allocatable::envnames(:)
-
-! NOTE: A parallel code might theoretically use multiple OS
-!x!FORT BUG:if(sep_cache /= ' ')then ! use cached value.
-!x!FORT BUG: sep=sep_cache
-!x!FORT BUG: return
-!x!FORT BUG:endif
-if(isep/=-1)then! use cached value.
-sep=char(isep)
-return
- endif
-FOUND:block
-! simple, but does not work with ifort
-! most MSWindows environments see to work with backslash even when
-! using POSIX filenames to do not rely on '\.'.
-inquire(file='/.',exist=existing,iostat=ios,name=name)
-if(existing.and.ios==0)then
-sep='/'
-exit FOUND
-endif
-! check variables names common to many platforms that usually have a
-! directory path in them although a ULS file can contain a backslash
-! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it
-! returned a name with backslash on CygWin, Mingw, WLS even when using
-! POSIX filenames in the environment.
-envnames=[character(len=10)::'PATH','HOME']
-do i=1,size(envnames)
-if(index(get_env(envnames(i)),'\') /= 0)then
- sep='\'
- exit FOUND
- elseif(index(get_env(envnames(i)),'/') /= 0)then
- sep='/'
- exit FOUND
- endif
- enddo
-
- write(*,*)'<WARNING>unknownsystem directorypathseparator'
- sep='\'
- endblock FOUND
- !x!IFORT BUG:sep_cache=sep
- isep=ichar(sep)
-end function separator
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-subroutine cmd_args_to_dictionary()
-! convert command line arguments to dictionary entries
-!x!logical :: guess_if_value
-integer :: pointer
-character(len=:),allocatable :: lastkeyword
-integer :: i, jj, kk
-integer :: ilength, istatus, imax
-character(len=1) :: letter
-character(len=:),allocatable :: current_argument
-character(len=:),allocatable :: current_argument_padded
-character(len=:),allocatable :: dummy
-character(len=:),allocatable :: oldvalue
-logical :: nomore
-logical :: next_mandatory
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:START'
- next_mandatory=.false.
- nomore=.false.
- pointer=0
- lastkeyword=''
- G_keyword_single_letter=.true.
- i=1
- GET_ARGS: do while (get_next_argument()) ! insert and replace entries
+ call locate_key('u',iused)
+if(iused<=0)then
+ call update('usage')
+call update('usage:u','F')
+endif
+
+present_in=.false.! reset all values to false so everything gets written
+endif
+
+ if(present(string))then! instead of command line arguments use another prototype string
+if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=',STRING
+call prototype_to_dictionary(string)! build dictionary from prototype
+else
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=',.true.
+call cmd_args_to_dictionary()
+endif
+
+ if(len(G_remaining)>1)then! if -- was in prototype then after -- on input return rest in this string
+itrim=len(G_remaining)
+if(G_remaining(itrim:itrim)==' ')then! was adding a space at end as building it, but do not want to remove blanks
+G_remaining=G_remaining(:itrim-1)
+endif
+remaining=G_remaining
+endif
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_NLIST:NORMAL END'
+end subroutine prototype_and_cmd_args_to_nlist
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+subroutine expand_response(name)
+character(len=*),intent(in)::name
+character(len=:),allocatable::prototype
+logical::hold
+
+if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:START:NAME=',name
+
+call get_prototype(name,prototype)
+
+if(prototype/='')then
+hold=G_append
+G_append=.false.
+if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=',prototype
+call prototype_to_dictionary(prototype)! build dictionary from prototype
+G_append=hold
+endif
+
+ if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:END'
+
+end subroutine expand_response
+!===================================================================================================================================
+subroutine get_prototype(name,prototype)! process @name abbreviations
+character(len=*),intent(in)::name
+character(len=:),allocatable,intent(out)::prototype
+character(len=:),allocatable::filename
+character(len=:),allocatable::os
+character(len=:),allocatable::plain_name
+character(len=:),allocatable::search_for
+integer::lun
+integer::ios
+integer::itrim
+character(len=4096)::line!x! assuming input never this long
+character(len=256)::message
+character(len=:),allocatable::array(:)! output array of tokens
+integer::lines_processed
+
+lines_processed=0
+plain_name=name//' '
+plain_name=trim(name(2:))
+os='@'//get_env('OSTYPE',get_env('OS'))
+if(G_DEBUG)write(*,gen)'<DEBUG>GET_PROTOTYPE:OS=',OS
+
+search_for=''
+! look for NAME.rsp and see if there is an @OS section in it and position to it and read
+if(os/='@')then
+search_for=os
+call find_and_read_response_file(plain_name)
+if(lines_processed/=0)return
+ endif
+
+! look for NAME.rsp and see if there is anything before an OS-specific section
+search_for=''
+call find_and_read_response_file(plain_name)
+if(lines_processed/=0)return
+
+! look for ARG0.rsp with @OS@NAME section in it and position to it
+if(os/='@')then
+search_for=os//name
+call find_and_read_response_file(basename(get_name(),suffix=.false.))
+if(lines_processed/=0)return
+ endif
+
+! look for ARG0.rsp with a section called @NAME in it and position to it
+search_for=name
+call find_and_read_response_file(basename(get_name(),suffix=.false.))
+if(lines_processed/=0)return
+
+ write(*,gen)'<ERROR> response name ['//trim(name)//'] not found'
+stop 1
+contains
+!===================================================================================================================================
+subroutine find_and_read_response_file(rname)
+! search for a simple file named the same as the @NAME field with one entry assumed in it
+character(len=*),intent(in)::rname
+character(len=:),allocatable::paths(:)
+character(len=:),allocatable::testpath
+character(len=256)::message
+integer::i
+integer::ios
+prototype=''
+! look for NAME.rsp
+! assume if have / or \ a full filename was supplied to support ifort(1)
+if((index(rname,'/')/=0.or.index(rname,'\') /= 0) .and. len(rname) > 1 )then
+ filename=rname
+ lun=fileopen(filename,message)
+ if(lun /= -1)then
+ call process_response()
+ close(unit=lun,iostat=ios)
+ endif
+ return
+ else
+ filename=rname//'.rsp'
+ endif
+ if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:FILENAME=',filename
+
+ ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories
+ call split(get_env('CLI_RESPONSE_PATH','~/.local/share/rsp'),paths)
+ paths=[character(len=len(paths)) :: '',paths]
+ if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:PATHS=',paths
+
+ do i=1,size(paths)
+ testpath=join_path(paths(i),filename)
+ lun=fileopen(testpath,message)
+ if(lun /= -1)then
+ if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:SEARCH_FOR=',search_for
+ if(search_for /= '') call position_response() ! set to end of file or where string was found
+ call process_response()
+ if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:LINES_PROCESSED=',LINES_PROCESSED
+ close(unit=lun,iostat=ios)
+ if(G_DEBUG)write(*,gen)'<DEBUG>FIND_AND_READ_RESPONSE_FILE:CLOSE:LUN=',LUN,'IOSTAT=',IOS
+ if(lines_processed /= 0)exit
+ endif
+ enddo
+
+end subroutine find_and_read_response_file
+!===================================================================================================================================
+subroutine position_response()
+integer :: ios
+ line=''
+ INFINITE: do
+ read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line
+ if(is_iostat_end(ios))then
+ if(G_DEBUG)write(*,gen)'<DEBUG>POSITION_RESPONSE:EOF'
+ backspace(lun,iostat=ios)
+ exit INFINITE
+ elseif(ios /= 0)then
+ write(*,gen)'<ERROR>*position_response*:'//trim(message)
+ exit INFINITE
+ endif
+ line=adjustl(line)
+ if(line == search_for)return
+ enddo INFINITE
+end subroutine position_response
+!===================================================================================================================================
+subroutine process_response()
+character(len=:),allocatable :: padded
+character(len=:),allocatable :: temp
+ line=''
+ lines_processed=0
+ INFINITE: do
+ read(unit=lun,fmt='(a)',iostat=ios,iomsg=message)line
+ if(is_iostat_end(ios))then
+ backspace(lun,iostat=ios)
+ exit INFINITE
+ elseif(ios /= 0)then
+ write(*,gen)'<ERROR>*process_response*:'//trim(message)
+ exit INFINITE
+ endif
+ line=trim(adjustl(line))
+ temp=line
+ if(index(temp//'','#') == 1)cycle
+ if(temp /= '')then
+
+ if(index(temp,'@') == 1.and.lines_processed /= 0)exit INFINITE
+
+ call split(temp,array) ! get first word
+ itrim=len_trim(array(1))+2
+ temp=temp(itrim:)
+
+ PROCESS: select case(lower(array(1)))
+ case('comment','#','')
+ case('system','!','$')
+if(G_options_only)exit PROCESS
+lines_processed=lines_processed+1
+call execute_command_line(temp)
+case('options','option','-')
+lines_processed=lines_processed+1
+prototype=prototype//' '//trim(temp)
+case('print','>','echo')
+if(G_options_only)exit PROCESS
+lines_processed=lines_processed+1
+write(*,'(a)')trim(temp)
+case('stop')
+if(G_options_only)exit PROCESS
+write(*,'(a)')trim(temp)
+stop
+ case default
+if(array(1)(1:1)=='-')then
+! assume these are simply options to support ifort(1)
+! if starts with a single dash must assume a single argument
+! and rest is value to support -Dname and -Ifile option
+! which currently is not supported, so multiple short keywords
+! does not work. Just a ifort(1) test at this point, so do not document
+if(G_options_only)exit PROCESS
+padded=trim(line)//' '
+if(padded(2:2)=='-')then
+prototype=prototype//' '//trim(line)
+else
+prototype=prototype//' '//padded(1:2)//' '//trim(padded(3:))
+endif
+lines_processed=lines_processed+1
+else
+ if(array(1)(1:1)=='@')cycle INFINITE!skip adjacent @ lines from first
+lines_processed=lines_processed+1
+write(*,'(*(g0))')'unknown response keyword [',array(1),'] with options of [',trim(temp),']'
+endif
+ end select PROCESS
+
+endif
+ enddo INFINITE
+end subroutine process_response
+
+end subroutine get_prototype
+!===================================================================================================================================
+function fileopen(filename,message)result(lun)
+character(len=*),intent(in)::filename
+character(len=*),intent(out),optional::message
+integer::lun
+integer::ios
+character(len=256)::message_local
+
+ios=0
+message_local=''
+open(file=filename,newunit=lun,&
+&form='formatted',access='sequential',action='read',&
+&position='rewind',status='old',iostat=ios,iomsg=message_local)
+
+if(ios/=0)then
+lun=-1
+if(present(message))then
+message=trim(message_local)
+else
+ write(*,gen)trim(message_local)
+endif
+ endif
+ if(G_DEBUG)write(*,gen)'<DEBUG>FILEOPEN:FILENAME=',filename,' LUN=',lun,' IOS=',IOS,' MESSAGE=',trim(message_local)
+
+end function fileopen
+!===================================================================================================================================
+function get_env(NAME,DEFAULT)result(VALUE)
+character(len=*),intent(in)::NAME
+character(len=*),intent(in),optional::DEFAULT
+character(len=:),allocatable::VALUE
+integer::howbig
+integer::stat
+integer::length
+! get length required to hold value
+length=0
+if(NAME/='')then
+ call get_environment_variable(NAME,length=howbig,status=stat,trim_name=.true.)
+select case(stat)
+case(1)
+!x!print *, NAME, " is not defined in the environment. Strange..."
+VALUE=''
+case(2)
+!x!print *, "This processor doesn't support environment variables. Boooh!"
+VALUE=''
+case default
+! make string to hold value of sufficient size
+if(allocated(value))deallocate(value)
+allocate(character(len=max(howbig,1))::VALUE)
+! get value
+call get_environment_variable(NAME,VALUE,status=stat,trim_name=.true.)
+if(stat/=0)VALUE=''
+end select
+ else
+ VALUE=''
+endif
+ if(VALUE==''.and.present(DEFAULT))VALUE=DEFAULT
+end function get_env
+!===================================================================================================================================
+function join_path(a1,a2,a3,a4,a5)result(path)
+! Construct path by joining strings with os file separator
+!
+character(len=*),intent(in)::a1,a2
+character(len=*),intent(in),optional::a3,a4,a5
+character(len=:),allocatable::path
+character(len=1)::filesep
+
+filesep=separator()
+if(a1/='')then
+path=trim(a1)//filesep//trim(a2)
+else
+path=trim(a2)
+endif
+ if(present(a3))path=path//filesep//trim(a3)
+if(present(a4))path=path//filesep//trim(a4)
+if(present(a5))path=path//filesep//trim(a5)
+path=adjustl(path//' ')
+path=path(1:1)//replace_str(path,filesep//filesep,'')! some systems allow names starting with '//' or '\\'
+path=trim(path)
+end function join_path
+!===================================================================================================================================
+function get_name()result(name)
+! get the pathname of arg0
+character(len=:),allocatable::arg0
+integer::arg0_length
+integer::istat
+character(len=4096)::long_name
+character(len=:),allocatable::name
+arg0_length=0
+name=''
+long_name=''
+call get_command_argument(0,length=arg0_length,status=istat)
+if(istat==0)then
+ if(allocated(arg0))deallocate(arg0)
+allocate(character(len=arg0_length)::arg0)
+call get_command_argument(0,arg0,status=istat)
+if(istat==0)then
+ inquire(file=arg0,iostat=istat,name=long_name)
+name=trim(long_name)
+else
+name=arg0
+endif
+ endif
+end function get_name
+!===================================================================================================================================
+function basename(path,suffix)result(base)
+! Extract filename from path with/without suffix
+!
+character(*),intent(In)::path
+logical,intent(in),optional::suffix
+character(:),allocatable::base
+
+character(:),allocatable::file_parts(:)
+logical::with_suffix
+
+if(.not.present(suffix))then
+with_suffix=.true.
+else
+with_suffix=suffix
+endif
- if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of
- elseif( current_argument == '-')then ! sort of
- current_argument='"stdin"'
- endif
- if( current_argument == '--' .and. nomore .eqv. .true. )then ! -- was already encountered
- elseif( current_argument == '--' )then ! everything after this goes into the unnamed array
- nomore=.true.
- pointer=0
- if(G_remaining_option_allowed)then
- G_remaining_on=.true.
- endif
- cycle GET_ARGS
- endif
-
- dummy=current_argument//''
- current_argument_padded=current_argument//''
-
- !x!guess_if_value=maybe_value()
-
- if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word
- G_keyword_single_letter=.false.
- if(lastkeyword /= '')then
- call ifnull()
- endif
- call locate_key(current_argument_padded(3:),pointer)
- if(pointer <= 0)then
- if(G_QUIET)then
- lastkeyword="UNKNOWN"
- pointer=0
- cycle GET_ARGS
- endif
- call print_dictionary('UNKNOWNLONG KEYWORD:'//current_argument)
- call mystop(1)
- return
- endif
- lastkeyword=trim(current_argument_padded(3:))
- next_mandatory=mandatory(pointer)
- elseif(.not.next_mandatory &
- & .and..not.nomore &
- & .and.current_argument_padded(1:1) == '-' &
- & .and.index("0123456789.",dummy(2:2)) == 0)then
- ! short word
- G_keyword_single_letter=.true.
- if(lastkeyword /= '')then
- call ifnull()
- endif
- call locate_key(current_argument_padded(2:),pointer)
- if(pointer <= 0)then ! name not found
- jj=len(current_argument)
- if(G_STRICT.and.jj > 2)then ! in strict mode this might be multiple single-character values
- do kk=2,jj
- letter=current_argument_padded(kk:kk)
- call locate_key(letter,pointer)
- if(pointer > 0)then
- call update(keywords(pointer),'T')
- else
- call print_dictionary('UNKNOWNCOMPOUNDSHORT KEYWORD:'//letter//'in'//current_argument)
- if(G_QUIET)then
- lastkeyword="UNKNOWN"
- pointer=0
- cycle GET_ARGS
- endif
- call mystop(2)
- return
- endif
- current_argument='-'//current_argument_padded(jj:jj)
- enddo
- else
- call print_dictionary('UNKNOWNSHORT KEYWORD:'//current_argument)
- if(G_QUIET)then
- lastkeyword="UNKNOWN"
- pointer=0
- cycle GET_ARGS
- endif
- call mystop(2)
- return
- endif
- endif
- lastkeyword=trim(current_argument_padded(2:))
- next_mandatory=mandatory(pointer)
- elseif(pointer == 0)then ! unnamed arguments
- if(G_remaining_on)then
- if(len(current_argument) < 1)then
- G_remaining=G_remaining//'""'
- elseif(current_argument(1:1) == '-')then
- !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//''
- G_remaining=G_remaining//'"'//current_argument//'"'
- else
- G_remaining=G_remaining//'"'//current_argument//'"'
- endif
- imax=max(len(args),len(current_argument))
- args=[character(len=imax) :: args,current_argument]
- else
- imax=max(len(unnamed),len(current_argument))
- if(scan(current_argument//'','@') == 1.and.G_response)then
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:1:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
- call expand_response(current_argument)
- else
- unnamed=[character(len=imax) :: unnamed,current_argument]
- endif
- endif
- else
- oldvalue=get(keywords(pointer))//''
- if(oldvalue(1:1) == '"')then
- current_argument=quote(current_argument(:ilength))
- endif
- if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter
- if(current_argument /= ' ')then
- if(G_remaining_on)then
- if(len(current_argument) < 1)then
- G_remaining=G_remaining//'"" '
- elseif(current_argument(1:1) == '-')then
- !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' '
- G_remaining=G_remaining//'"'//current_argument//'" '
- else
- G_remaining=G_remaining//'"'//current_argument//'" '
- endif
- imax=max(len(args),len(current_argument))
- args=[character(len=imax) :: args,current_argument]
- else
- imax=max(len(unnamed),len(current_argument))
- if(scan(current_argument//' ','@') == 1.and.G_response)then
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
- call expand_response(current_argument)
- else
- unnamed=[character(len=imax) :: unnamed,current_argument]
- endif
- endif
- endif
- current_argument='T'
- endif
- call update(keywords(pointer),current_argument)
- pointer=0
- lastkeyword=''
- next_mandatory=.false.
- endif
- enddo GET_ARGS
- if(lastkeyword /= '')then
- call ifnull()
- endif
- if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:NORMAL END'
-
-contains
-
-subroutine ifnull()
- oldvalue=get(lastkeyword)//' '
- if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then
- call update(lastkeyword,'T')
- elseif(oldvalue(1:1) == '"')then
- call update(lastkeyword,'" "')
- else
- call update(lastkeyword,'')
- endif
-end subroutine ifnull
-
-function get_next_argument()
-!
-! get next argument from command line into allocated variable current_argument
-!
-logical,save :: hadequal=.false.
-character(len=:),allocatable,save :: right_hand_side
-logical :: get_next_argument
-integer :: iright
-integer :: iequal
-
- if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax
- current_argument=right_hand_side
- right_hand_side=''
- hadequal=.false.
- get_next_argument=.true.
- ilength=len(current_argument)
- return
- endif
-
- if(i>command_argument_count())then
- get_next_argument=.false.
- return
- else
- get_next_argument=.true.
- endif
-
- call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument
- if(istatus /= 0) then ! on error
- write(warn,*)'*prototype_and_cmd_args_to_nlist*errorobtainingargument',i,&
- &'status=',istatus,&
- &'length=',ilength
- get_next_argument=.false.
- else
- ilength=max(ilength,1)
- if(allocated(current_argument))deallocate(current_argument)
- allocate(character(len=ilength) :: current_argument)
- call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument
- if(istatus /= 0) then ! on error
- write(warn,*)'*prototype_and_cmd_args_to_nlist*errorobtainingargument',i,&
- &'status=',istatus,&
- &'length=',ilength,&
- &'target length=',len(current_argument)
- get_next_argument=.false.
- endif
-
- ! if an argument keyword and an equal before a space split on equal and save right hand side for next call
- if(nomore)then
- elseif( len(current_argument) == 0)then
- else
- iright=index(current_argument,'')
- if(iright == 0)iright=len(current_argument)
- iequal=index(current_argument(:iright),'=')
- if(next_mandatory)then
- elseif(iequal /= 0.and.current_argument(1:1) == '-')then
- if(iequal /= len(current_argument))then
- right_hand_side=current_argument(iequal+1:)
- else
- right_hand_side=''
- endif
- hadequal=.true.
- current_argument=current_argument(:iequal-1)
- endif
- endif
- endif
- i=i+1
-end function get_next_argument
-
-function maybe_value()
-! if previous keyword value type is a string and it was
-! given a null string because this value starts with a -
-! try to see if this is a string value starting with a -
-! to try to solve the vexing problem of values starting
-! with a dash.
-logical :: maybe_value
-integer :: pointer
-character(len=:),allocatable :: oldvalue
-
- oldvalue=get(lastkeyword)//''
- if(current_argument_padded(1:1) /= '-')then
- maybe_value=.true.
- elseif(oldvalue(1:1) /= '"')then
- maybe_value=.false.
- elseif(index(current_argument,' ') /= 0)then
- maybe_value=.true.
- elseif(scan(current_argument,",:;!@#$%^&*+=()[]{}\|'""./><?") /= 0)then
-maybe_value=.true.
-else! the last value was a null string so see if this matches an allowed parameter
-pointer=0
-if(current_argument_padded(1:2)=='--')then
- call locate_key(current_argument_padded(3:),pointer)
-elseif(current_argument_padded(1:1)=='-')then
- call locate_key(current_argument_padded(2:),pointer)
-endif
- if(pointer<=0)then
-maybe_value=.true.
-else! matched an option name so LIKELY is not a value
-maybe_value=.false.
-endif
- endif
-end function maybe_value
-
-end subroutine cmd_args_to_dictionary
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary
-!! created by calls to set_args(3f)
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine print_dictionary(header,stop)
-!!
-!! character(len=*),intent(in),optional :: header
-!! logical,intent(in),optional :: stop
-!!##DESCRIPTION
-!! Print the internal dictionary created by calls to set_args(3f).
-!! This routine is intended to print the state of the argument list
-!! if an error occurs in using the set_args(3f) procedure.
-!!##OPTIONS
-!! HEADER label to print before printing the state of the command
-!! argument list.
-!! STOP logical value that if true stops the program after displaying
-!! the dictionary.
-!!##EXAMPLE
-!!
-!!
-!!
-!! Typical usage:
-!!
-!! program demo_print_dictionary
-!! use M_CLI2, only : set_args, get_args
-!! implicit none
-!! real :: x, y, z
-!! call set_args('-x 10 -y 20 -z 30')
-!! call get_args('x',x,'y',y,'z',z)
-!! ! all done cracking the command line; use the values in your program.
-!! write(*,*)x,y,z
-!! end program demo_print_dictionary
-!!
-!! Sample output
-!!
-!! Calling the sample program with an unknown parameter or the --usage
-!! switch produces the following:
-!!
-!! $ ./demo_print_dictionary -A
-!! UNKNOWN SHORT KEYWORD: -A
-!! KEYWORD PRESENT VALUE
-!! z F [3]
-!! y F [2]
-!! x F [1]
-!! help F [F]
-!! version F [F]
-!! usage F [F]
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-subroutine print_dictionary(header,stop)
-character(len=*),intent(in),optional::header
-logical,intent(in),optional::stop
-integer::i
-if(G_QUIET)return
- if(present(header))then
- if(header/='')then
- write(warn,'(a)')header
-endif
- endif
- if(allocated(keywords))then
- if(size(keywords)>0)then
- write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE'
-write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))')&
-&(atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=1,size(keywords))
-endif
- endif
- if(allocated(unnamed))then
- if(size(unnamed)>0)then
- write(warn,'(a)')'UNNAMED'
-write(warn,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
-endif
- endif
- if(allocated(args))then
- if(size(args)>0)then
- write(warn,'(a)')'ARGS'
-write(warn,'(i6.6,3a)')(i,'[',args(i),']',i=1,size(args))
-endif
- endif
- if(G_remaining/='')then
- write(warn,'(a)')'REMAINING'
-write(warn,'(a)')G_remaining
-endif
- if(present(stop))then
- if(stop)call mystop(5)
-endif
-end subroutine print_dictionary
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters)result(strtok_status)
-! JSU- 20151030
-
-! ident_6="@(#) M_CLI2 strtok(3f) Tokenize a string"
-
-character(len=*),intent(in)::source_string! Source string to tokenize.
-character(len=*),intent(in)::delimiters! list of separator characters. May change between calls
-integer,intent(inout)::itoken! token count since started
-logical::strtok_status! returned value
-integer,intent(out)::token_start! beginning of token found if function result is .true.
-integer,intent(inout)::token_end! end of token found if function result is .true.
-integer::isource_len
-!----------------------------------------------------------------------------------------------------------------------------
-! calculate where token_start should start for this pass
-if(itoken<=0)then! this is assumed to be the first call
-token_start=1
-else! increment start to previous end + 1
-token_start=token_end+1
-endif
-!----------------------------------------------------------------------------------------------------------------------------
-isource_len=len(source_string)! length of input string
-!----------------------------------------------------------------------------------------------------------------------------
-if(token_start>isource_len)then! user input error or at end of string
-token_end=isource_len! assume end of token is end of string until proven otherwise so it is set
-strtok_status=.false.
-return
- endif
-!----------------------------------------------------------------------------------------------------------------------------
-! find beginning of token
-do while(token_start<=isource_len)! step thru each character to find next delimiter, if any
-if(index(delimiters,source_string(token_start:token_start))/=0)then
-token_start=token_start+1
-else
- exit
- endif
- enddo
-!----------------------------------------------------------------------------------------------------------------------------
-token_end=token_start
-do while(token_end<=isource_len-1)! step thru each character to find next delimiter, if any
-if(index(delimiters,source_string(token_end+1:token_end+1))/=0)then! found a delimiter in next character
-exit
- endif
-token_end=token_end+1
-enddo
-!----------------------------------------------------------------------------------------------------------------------------
-if(token_start>isource_len)then! determine if finished
-strtok_status=.false.! flag that input string has been completely processed
-else
-itoken=itoken+1! increment count of tokens found
-strtok_status=.true.! flag more tokens may remain
-endif
-!----------------------------------------------------------------------------------------------------------------------------
-end function strtok
-!==================================================================================================================================!
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!==================================================================================================================================!
-!>
-!!##NAME
-!! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing
-!! command line arguments
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! get_args(3f) and its convenience functions:
-!!
-!! use M_CLI2, only : get_args
-!! ! convenience functions
-!! use M_CLI2, only : dget, iget, lget, rget, sget, cget
-!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
-!!
-!! subroutine get_args(name,value,delimiters)
-!!
-!! character(len=*),intent(in) :: name
-!!
-!! type(${TYPE}),allocatable,intent(out) :: value(:)
-!! ! or
-!! type(${TYPE}),allocatable,intent(out) :: value
-!!
-!! character(len=*),intent(in),optional :: delimiters
-!!
-!! where ${TYPE} may be from the set
-!! {real,doubleprecision,integer,logical,complex,character(len=:)}
-!!##DESCRIPTION
-!!
-!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f)
-!! has been called. For fixed-length CHARACTER variables
-!! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
-!! GET_ARGS_FIXED_SIZE(3f).
-!!
-!! As a convenience multiple pairs of keywords and variables may be
-!! specified if and only if all the values are scalars and the CHARACTER
-!! variables are fixed-length or pre-allocated.
-!!
-!!##OPTIONS
-!!
-!! NAME name of commandline argument to obtain the value of
-!! VALUE variable to hold returned value. The kind of the value
-!! is used to determine the type of returned value. May
-!! be a scalar or allocatable array. If type is CHARACTER
-!! the scalar must have an allocatable length.
-!! DELIMITERS By default the delimiter for array values are comma,
-!! colon, and whitespace. A string containing an alternate
-!! list of delimiter characters may be supplied.
-!!
-!!##CONVENIENCE FUNCTIONS
-!!
-!! There are convenience functions that are replacements for calls to
-!! get_args(3f) for each supported default intrinsic type
-!!
-!! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f),
-!! cget(3f)
-!! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f),
-!! sgets(3f), cgets(3f)
-!!
-!! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL,
-!! S for string (CHARACTER), and C for COMPLEX.
-!!
-!! If the functions are called with no argument they will return the
-!! UNNAMED array converted to the specified type.
-!!
-!!##EXAMPLE
-!!
-!!
-!! Sample program:
-!!
-!! program demo_get_args
-!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
-!! implicit none
-!! integer :: i
-!! ! DEFINE ARGS
-!! real :: x, y, z
-!! real,allocatable :: p(:)
-!! character(len=:),allocatable :: title
-!! logical :: l, lbig
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o only quote strings and use double-quotes
-!! ! o set all logical values to F or T.
-!! call set_args(' &
-!! & -x 1 -y 2 -z 3 &
-!! & -p -1,-2,-3 &
-!! & --title "my title" &
-!! & -l F -L F &
-!! & --label " " &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! ! SCALARS
-!! call get_args('x',x,'y',y,'z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! ! ALLOCATABLE STRING
-!! call get_args('title',title)
-!! ! NON-ALLOCATABLE ARRAYS
-!! call get_args('p',p)
-!! ! USE VALUES
-!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
-!! write(*,*)'p=',p
-!! write(*,*)'title=',title
-!! write(*,*)'l=',l
-!! write(*,*)'L=',lbig
-!! if(size(filenames) > 0)then
-!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
-!! endif
-!! end program demo_get_args
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-!>
-!!##NAME
-!! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values
-!! for fixed-length string when parsing command line
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine get_args_fixed_length(name,value)
-!!
-!! character(len=:),allocatable :: value
-!! character(len=*),intent(in),optional :: delimiters
-!!
-!!##DESCRIPTION
-!!
-!! GET_ARGS_fixed_length(3f) returns the value of a string
-!! keyword when the string value is a fixed-length CHARACTER
-!! variable.
-!!
-!!##OPTIONS
-!!
-!! NAME name of commandline argument to obtain the value of
-!!
-!! VALUE variable to hold returned value.
-!! Must be a fixed-length CHARACTER variable.
-!!
-!! DELIMITERS By default the delimiter for array values are comma,
-!! colon, and whitespace. A string containing an alternate
-!! list of delimiter characters may be supplied.
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_get_args_fixed_length
-!! use M_CLI2, only : set_args, get_args_fixed_length
-!! implicit none
-!! ! DEFINE ARGS
-!! character(len=80) :: title
-!! call set_args(' &
-!! & --title "my title" &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args_fixed_length('title',title)
-!! ! USE VALUES
-!! write(*,*)'title=',title
-!! end program demo_get_args_fixed_length
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-!>
-!!##NAME
-!! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values
-!! for fixed-size array when parsing command line arguments
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine get_args_fixed_size(name,value)
-!!
-!! [real|doubleprecision|integer|logical|complex] :: value(NNN)
-!! or
-!! character(len=MMM) :: value(NNN)
-!!
-!! character(len=*),intent(in),optional :: delimiters
-!!
-!!##DESCRIPTION
-!!
-!! GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for
-!! fixed-size arrays after SET_ARGS(3f) has been called.
-!! On input on the command line all values of the array must
-!! be specified.
-!!
-!!##OPTIONS
-!! NAME name of commandline argument to obtain the value of
-!!
-!! VALUE variable to hold returned values. The kind of the value
-!! is used to determine the type of returned value. Must be
-!! a fixed-size array. If type is CHARACTER the length must
-!! also be fixed.
-!!
-!! DELIMITERS By default the delimiter for array values are comma,
-!! colon, and whitespace. A string containing an alternate
-!! list of delimiter characters may be supplied.
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_get_args_fixed_size
-!! use M_CLI2, only : set_args, get_args_fixed_size
-!! implicit none
-!! integer,parameter :: dp=kind(0.0d0)
-!! ! DEFINE ARGS
-!! real :: x(2)
-!! real(kind=dp) :: y(2)
-!! integer :: p(3)
-!! character(len=80) :: title(1)
-!! logical :: l(4), lbig(4)
-!! complex :: cmp(2)
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o only quote strings
-!! ! o set all logical values to F or T.
-!! call set_args(' &
-!! & -x 10.0,20.0 &
-!! & -y 11.0,22.0 &
-!! & -p -1,-2,-3 &
-!! & --title "my title" &
-!! & -l F,T,F,T -L T,F,T,F &
-!! & --cmp 111,222.0,333.0e0,4444 &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args_fixed_size('x',x)
-!! call get_args_fixed_size('y',y)
-!! call get_args_fixed_size('p',p)
-!! call get_args_fixed_size('title',title)
-!! call get_args_fixed_size('l',l)
-!! call get_args_fixed_size('L',lbig)
-!! call get_args_fixed_size('cmp',cmp)
-!! ! USE VALUES
-!! write(*,*)'x=',x
-!! write(*,*)'p=',p
-!! write(*,*)'title=',title
-!! write(*,*)'l=',l
-!! write(*,*)'L=',lbig
-!! write(*,*)'cmp=',cmp
-!! end program demo_get_args_fixed_size
-!! Results:
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-subroutine get_fixedarray_class(keyword,generic,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-class(*)::generic(:)
-character(len=*),intent(in),optional::delimiters
-select type(generic)
-type is(character(len=*));call get_fixedarray_fixed_length_c(keyword,generic,delimiters)
-type is(integer);call get_fixedarray_i(keyword,generic,delimiters)
-type is(real);call get_fixedarray_r(keyword,generic,delimiters)
-type is(complex);call get_fixed_size_complex(keyword,generic,delimiters)
-type is(real(kind=dp));call get_fixedarray_d(keyword,generic,delimiters)
-type is(logical);call get_fixedarray_l(keyword,generic,delimiters)
-class default
-call mystop(-7,'*get_fixedarray_class* crud -- procedure does not know about this type')
-end select
-end subroutine get_fixedarray_class
-!===================================================================================================================================
-! return allocatable arrays
-!===================================================================================================================================
-subroutine get_anyarray_l(keyword,larray,delimiters)
-
-! ident_7="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)"
-
-character(len=*),intent(in)::keyword! the dictionary keyword (in form VERB_KEYWORD) to retrieve
-logical,allocatable::larray(:)! convert value to an array
-character(len=*),intent(in),optional::delimiters
-character(len=:),allocatable::carray(:)! convert value to an array
-character(len=:),allocatable::val
-integer::i
-integer::place
-integer::iichar! point to first character of word unless first character is "."
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if string was found
-val=values(place)(:counts(place))
-call split(adjustl(upper(val)),carray,delimiters=delimiters)! convert value to uppercase, trimmed; then parse into array
-else
- call journal('sc','*get_anyarray_l* unknown keyword '//keyword)
-call mystop(8,'*get_anyarray_l* unknown keyword '//keyword)
-if(allocated(larray))deallocate(larray)
-allocate(larray(0))
-return
- endif
- if(size(carray)>0)then! if not a null string
-if(allocated(larray))deallocate(larray)
-allocate(larray(size(carray)))! allocate output array
-do i=1,size(carray)
-larray(i)=.false.! initialize return value to .false.
-if(carray(i)(1:1)=='.')then! looking for fortran logical syntax .STRING.
-iichar=2
-else
-iichar=1
-endif
- select case(carray(i)(iichar:iichar))! check word to see if true or false
-case('T','Y',' ');larray(i)=.true.! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
-case('F','N');larray(i)=.false.! assume this is false or no
-case default
-call journal('sc',"*get_anyarray_l* bad logical expression for "//trim(keyword)//'='//carray(i))
-end select
- enddo
- else! for a blank string return one T
-if(allocated(larray))deallocate(larray)
-allocate(larray(1))! allocate output array
-larray(1)=.true.
-endif
-end subroutine get_anyarray_l
-!===================================================================================================================================
-subroutine get_anyarray_d(keyword,darray,delimiters)
-
-! ident_8="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)"
-
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real(kind=dp),allocatable,intent(out)::darray(:)! function type
-character(len=*),intent(in),optional::delimiters
-
-character(len=:),allocatable::carray(:)! convert value to an array using split(3f)
-integer::i
-integer::place
-integer::ierr
-character(len=:),allocatable::val
-!-----------------------------------------------------------------------------------------------------------------------------------
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if string was found
-val=values(place)(:counts(place))
-val=replace_str(val,'(','')
-val=replace_str(val,')','')
-call split(val,carray,delimiters=delimiters)! find value associated with keyword and split it into an array
-else
- call journal('sc','*get_anyarray_d* unknown keyword '//keyword)
-call mystop(9,'*get_anyarray_d* unknown keyword '//keyword)
-if(allocated(darray))deallocate(darray)
-allocate(darray(0))
-return
- endif
- if(allocated(darray))deallocate(darray)
-allocate(darray(size(carray)))! create the output array
-do i=1,size(carray)
-call a2d(carray(i),darray(i),ierr)! convert the string to a numeric value
-if(ierr/=0)then
- call mystop(10,'*get_anyarray_d* unreadable value '//carray(i)//' for keyword '//keyword)
-endif
- enddo
-end subroutine get_anyarray_d
-!===================================================================================================================================
-subroutine get_anyarray_i(keyword,iarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-integer,allocatable::iarray(:)
-character(len=*),intent(in),optional::delimiters
-real(kind=dp),allocatable::darray(:)! function type
-call get_anyarray_d(keyword,darray,delimiters)
-iarray=nint(darray)
-end subroutine get_anyarray_i
-!===================================================================================================================================
-subroutine get_anyarray_r(keyword,rarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real,allocatable::rarray(:)
-character(len=*),intent(in),optional::delimiters
-real(kind=dp),allocatable::darray(:)! function type
-call get_anyarray_d(keyword,darray,delimiters)
-rarray=real(darray)
-end subroutine get_anyarray_r
-!===================================================================================================================================
-subroutine get_anyarray_x(keyword,xarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-complex(kind=sp),allocatable::xarray(:)
-character(len=*),intent(in),optional::delimiters
-real(kind=dp),allocatable::darray(:)! function type
-integer::half,sz,i
-call get_anyarray_d(keyword,darray,delimiters)
-sz=size(darray)
-half=sz/2
-if(sz/=half+half)then
- call journal('sc','*get_anyarray_x* uneven number of values defining complex value '//keyword)
-call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword)
-if(allocated(xarray))deallocate(xarray)
-allocate(xarray(0))
-endif
-
-!x!================================================================================================
-!x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2)))
-if(allocated(xarray))deallocate(xarray)
-allocate(xarray(half))
-do i=1,sz,2
-xarray((i+1)/2)=cmplx(darray(i),darray(i+1),kind=sp)
-enddo
-!x!================================================================================================
-
-end subroutine get_anyarray_x
-!===================================================================================================================================
-subroutine get_anyarray_c(keyword,strings,delimiters)
-
-! ident_8="@(#)M_CLI2::get_anyarray_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary"
-
-! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
-character(len=*),intent(in)::keyword! name to look up in dictionary
-character(len=:),allocatable::strings(:)
-character(len=*),intent(in),optional::delimiters
-integer::place
-character(len=:),allocatable::val
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if index is valid return strings
-val=unquote(values(place)(:counts(place)))
-call split(val,strings,delimiters=delimiters)! find value associated with keyword and split it into an array
-else
- call journal('sc','*get_anyarray_c* unknown keyword '//keyword)
-call mystop(12,'*get_anyarray_c* unknown keyword '//keyword)
-if(allocated(strings))deallocate(strings)
-allocate(character(len=0)::strings(0))
-endif
-end subroutine get_anyarray_c
-!===================================================================================================================================
-!===================================================================================================================================
-subroutine get_args_fixed_length_a_array(keyword,strings,delimiters)
-
-! ident_9="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
-
-! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
-character(len=*),intent(in)::keyword! name to look up in dictionary
-character(len=*),allocatable::strings(:)
-character(len=*),intent(in),optional::delimiters
-character(len=:),allocatable::strings_a(:)
-integer::place
-character(len=:),allocatable::val
-integer::ibug
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if index is valid return strings
-val=unquote(values(place)(:counts(place)))
-call split(val,strings_a,delimiters=delimiters)! find value associated with keyword and split it into an array
-if(len(strings_a)<=len(strings))then
-strings=strings_a
-else
-ibug=len(strings)
-call journal('sc','*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug)
-write(*,'("strings=",3x,*(a,1x))')strings
-call journal('sc','*get_args_fixed_length_a_array* keyword='//keyword)
-call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword)
-strings=[character(len=len(strings))::]
-endif
- else
- call journal('sc','*get_args_fixed_length_a_array* unknown keyword '//keyword)
-call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword)
-strings=[character(len=len(strings))::]
-endif
-end subroutine get_args_fixed_length_a_array
-!===================================================================================================================================
-! return non-allocatable arrays
-!===================================================================================================================================
-subroutine get_fixedarray_i(keyword,iarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-integer::iarray(:)
-character(len=*),intent(in),optional::delimiters
-real(kind=dp),allocatable::darray(:)! function type
-integer::dsize
-integer::ibug
-call get_anyarray_d(keyword,darray,delimiters)
-dsize=size(darray)
-if(ubound(iarray,dim=1)==dsize)then
-iarray=nint(darray)
-else
-ibug=size(iarray)
-call journal('sc','*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
-call print_dictionary('USAGE:')
-call mystop(33)
-iarray=0
-endif
-end subroutine get_fixedarray_i
-!===================================================================================================================================
-subroutine get_fixedarray_r(keyword,rarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real::rarray(:)
-character(len=*),intent(in),optional::delimiters
-real,allocatable::darray(:)! function type
-integer::dsize
-integer::ibug
-call get_anyarray_r(keyword,darray,delimiters)
-dsize=size(darray)
-if(ubound(rarray,dim=1)==dsize)then
-rarray=darray
-else
-ibug=size(rarray)
-call journal('sc','*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
-call print_dictionary('USAGE:')
-call mystop(33)
-rarray=0.0
-endif
-end subroutine get_fixedarray_r
-!===================================================================================================================================
-subroutine get_fixed_size_complex(keyword,xarray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-complex::xarray(:)
-character(len=*),intent(in),optional::delimiters
-complex,allocatable::darray(:)! function type
-integer::half,sz
-integer::dsize
-integer::ibug
-call get_anyarray_x(keyword,darray,delimiters)
-dsize=size(darray)
-sz=dsize*2
-half=sz/2
-if(sz/=half+half)then
- call journal('sc','*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
-call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
-xarray=0
-return
- endif
- if(ubound(xarray,dim=1)==dsize)then
-xarray=darray
-else
-ibug=size(xarray)
-call journal('sc','*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
-call print_dictionary('USAGE:')
-call mystop(34)
-xarray=cmplx(0.0,0.0)
-endif
-end subroutine get_fixed_size_complex
-!===================================================================================================================================
-subroutine get_fixedarray_d(keyword,darr,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real(kind=dp)::darr(:)
-character(len=*),intent(in),optional::delimiters
-real(kind=dp),allocatable::darray(:)! function type
-integer::dsize
-integer::ibug
-call get_anyarray_d(keyword,darray,delimiters)
-dsize=size(darray)
-if(ubound(darr,dim=1)==dsize)then
-darr=darray
-else
-ibug=size(darr)
-call journal('sc','*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
-call print_dictionary('USAGE:')
-call mystop(35)
-darr=0.0d0
-endif
-end subroutine get_fixedarray_d
-!===================================================================================================================================
-subroutine get_fixedarray_l(keyword,larray,delimiters)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-logical::larray(:)
-character(len=*),intent(in),optional::delimiters
-logical,allocatable::darray(:)! function type
-integer::dsize
-integer::ibug
-call get_anyarray_l(keyword,darray,delimiters)
-dsize=size(darray)
-if(ubound(larray,dim=1)==dsize)then
-larray=darray
-else
-ibug=size(larray)
-call journal('sc','*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
-call print_dictionary('USAGE:')
-call mystop(36)
-larray=.false.
-endif
-end subroutine get_fixedarray_l
-!===================================================================================================================================
-subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters)
-
-! ident_10="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
-
-! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
-character(len=*)::strings(:)
-character(len=*),intent(in),optional::delimiters
-character(len=:),allocatable::str(:)
-character(len=*),intent(in)::keyword! name to look up in dictionary
-integer::place
-integer::ssize
-integer::ibug
-character(len=:),allocatable::val
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if index is valid return strings
-val=unquote(values(place)(:counts(place)))
-call split(val,str,delimiters=delimiters)! find value associated with keyword and split it into an array
-ssize=size(str)
-if(ssize==size(strings))then
-strings(:ssize)=str
-else
-ibug=size(strings)
-call journal('sc','*get_fixedarray_fixed_length_c* wrong number of values for keyword',&
-&keyword,'got',ssize,'expected ',ibug)!,ubound(strings,dim=1)
-call print_dictionary('USAGE:')
-call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
-strings=''
-endif
- else
- call journal('sc','*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
-call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
-strings=''
-endif
-end subroutine get_fixedarray_fixed_length_c
-!===================================================================================================================================
-! return scalars
-!===================================================================================================================================
-subroutine get_scalar_d(keyword,d)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real(kind=dp)::d
-real(kind=dp),allocatable::darray(:)! function type
-integer::ibug
-call get_anyarray_d(keyword,darray)
-if(size(darray)==1)then
-d=darray(1)
-else
-ibug=size(darray)
-call journal('sc','*get_anyarray_d* incorrect number of values for keyword',keyword,'expected one found',ibug)
-call print_dictionary('USAGE:')
-call mystop(31,'*get_anyarray_d* incorrect number of values for keyword'//keyword//'expected one')
-endif
-end subroutine get_scalar_d
-!===================================================================================================================================
-subroutine get_scalar_real(keyword,r)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-real,intent(out)::r
-real(kind=dp)::d
-call get_scalar_d(keyword,d)
-r=real(d)
-end subroutine get_scalar_real
-!===================================================================================================================================
-subroutine get_scalar_i(keyword,i)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-integer,intent(out)::i
-real(kind=dp)::d
-call get_scalar_d(keyword,d)
-i=nint(d)
-end subroutine get_scalar_i
-!===================================================================================================================================
-subroutine get_scalar_anylength_c(keyword,string)
-
-! ident_11="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
-
-! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
-character(len=*),intent(in)::keyword! name to look up in dictionary
-character(len=:),allocatable,intent(out)::string
-integer::place
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if index is valid return string
-string=unquote(values(place)(:counts(place)))
-else
- call mystop(17,'*get_anyarray_c* unknown keyword '//keyword)
-call journal('sc','*get_anyarray_c* unknown keyword '//keyword)
-string=''
+ if(with_suffix)then
+ call split(path,file_parts,delimiters='\/')
+if(size(file_parts)>0)then
+base=trim(file_parts(size(file_parts)))
+else
+base=''
+endif
+ else
+ call split(path,file_parts,delimiters='\/.')
+if(size(file_parts)>=2)then
+base=trim(file_parts(size(file_parts)-1))
+elseif(size(file_parts)==1)then
+base=trim(file_parts(1))
+else
+base=''
+endif
+ endif
+end function basename
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+function separator()result(sep)
+!>
+!!##NAME
+!! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! function separator() result(sep)
+!!
+!! character(len=1) :: sep
+!!
+!!##DESCRIPTION
+!! First testing for the existence of "/.", then if that fails a list
+!! of variable names assumed to contain directory paths {PATH|HOME} are
+!! examined first for a backslash, then a slash. Assuming basically the
+!! choice is a ULS or MSWindows system, and users can do weird things like
+!! put a backslash in a ULS path and break it.
+!!
+!! Therefore can be very system dependent. If the queries fail the
+!! default returned is "/".
+!!
+!!##EXAMPLE
+!!
+!! sample usage
+!!
+!! program demo_separator
+!! use M_io, only : separator
+!! implicit none
+!! write(*,*)'separator=',separator()
+!! end program demo_separator
+
+! use the pathname returned as arg0 to determine pathname separator
+integer::ios
+integer::i
+logical::existing=.false.
+character(len=1)::sep
+!x!IFORT BUG:character(len=1),save :: sep_cache=' '
+integer,save::isep=-1
+character(len=4096)::name
+character(len=:),allocatable::envnames(:)
+
+! NOTE: A parallel code might theoretically use multiple OS
+!x!FORT BUG:if(sep_cache /= ' ')then ! use cached value.
+!x!FORT BUG: sep=sep_cache
+!x!FORT BUG: return
+!x!FORT BUG:endif
+if(isep/=-1)then! use cached value.
+sep=char(isep)
+return
+ endif
+FOUND:block
+! simple, but does not work with ifort
+! most MSWindows environments see to work with backslash even when
+! using POSIX filenames to do not rely on '\.'.
+inquire(file='/.',exist=existing,iostat=ios,name=name)
+if(existing.and.ios==0)then
+sep='/'
+exit FOUND
+endif
+! check variables names common to many platforms that usually have a
+! directory path in them although a ULS file can contain a backslash
+! and vice-versa (eg. "touch A\\B\\C"). Removed HOMEPATH because it
+! returned a name with backslash on CygWin, Mingw, WLS even when using
+! POSIX filenames in the environment.
+envnames=[character(len=10)::'PATH','HOME']
+do i=1,size(envnames)
+if(index(get_env(envnames(i)),'\') /= 0)then
+ sep='\'
+ exit FOUND
+ elseif(index(get_env(envnames(i)),'/') /= 0)then
+ sep='/'
+ exit FOUND
+ endif
+ enddo
+
+ write(*,*)'<WARNING>unknownsystem directorypathseparator'
+ sep='\'
+ endblock FOUND
+ !x!IFORT BUG:sep_cache=sep
+ isep=ichar(sep)
+end function separator
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+subroutine cmd_args_to_dictionary()
+! convert command line arguments to dictionary entries
+!x!logical :: guess_if_value
+integer :: pointer
+character(len=:),allocatable :: lastkeyword
+integer :: i, jj, kk
+integer :: ilength, istatus, imax
+character(len=1) :: letter
+character(len=:),allocatable :: current_argument
+character(len=:),allocatable :: current_argument_padded
+character(len=:),allocatable :: dummy
+character(len=:),allocatable :: oldvalue
+logical :: nomore
+logical :: next_mandatory
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:START'
+ next_mandatory=.false.
+ nomore=.false.
+ pointer=0
+ lastkeyword=''
+ G_keyword_single_letter=.true.
+ i=1
+ current_argument=''
+ GET_ARGS: do while (get_next_argument()) ! insert and replace entries
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:WHILE:CURRENT_ARGUMENT=',current_argument
+
+ if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of
+ elseif( current_argument == '-')then ! sort of
+ current_argument='"stdin"'
+ endif
+ if( current_argument == '--' .and. nomore .eqv. .true. )then ! -- was already encountered
+ elseif( current_argument == '--' )then ! everything after this goes into the unnamed array
+ nomore=.true.
+ pointer=0
+ if(G_remaining_option_allowed)then
+ G_remaining_on=.true.
+ endif
+ cycle GET_ARGS
+ endif
+
+ dummy=current_argument//''
+ current_argument_padded=current_argument//''
+
+ if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:START_LONG:'
+ G_keyword_single_letter=.false.
+ if(lastkeyword /= '')then
+ call ifnull()
+ endif
+ call locate_key(current_argument_padded(3:),pointer)
+ if(pointer <= 0)then
+ if(G_QUIET)then
+ lastkeyword="UNKNOWN"
+ pointer=0
+ cycle GET_ARGS
+ endif
+ call print_dictionary('UNKNOWNLONG KEYWORD:'//current_argument)
+ call mystop(1)
+ return
+ endif
+ lastkeyword=trim(current_argument_padded(3:))
+ next_mandatory=mandatory(pointer)
+ elseif(.not.next_mandatory &
+ & .and..not.nomore &
+ & .and.current_argument_padded(1:1) == '-' &
+ & .and.index("0123456789.",dummy(2:2)) == 0)then
+ ! short word
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:START_SHORT'
+ G_keyword_single_letter=.true.
+ if(lastkeyword /= '')then
+ call ifnull()
+ endif
+ call locate_key(current_argument_padded(2:),pointer)
+ jj=len(current_argument)
+ if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:SHORT NOT FOUND:',current_argument_padded(2:)
+ ! in strict mode this might be multiple single-character values
+ do kk=2,jj
+ letter=current_argument_padded(kk:kk)
+ call locate_key(letter,pointer)
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:LETTER:',letter,pointer
+ if(pointer > 0)then
+ call update(keywords(pointer),'T')
+ else
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:UNKNOWNSHORT:',letter
+ call print_dictionary('UNKNOWNSHORT KEYWORD:'//letter) ! //'in'//current_argument)
+ if(G_QUIET)then
+ lastkeyword="UNKNOWN"
+ pointer=0
+ cycle GET_ARGS
+ endif
+ call mystop(2)
+ return
+ endif
+ current_argument='-'//current_argument_padded(jj:jj)
+ enddo
+ !--------------
+ lastkeyword=""
+ pointer=0
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:SHORT_END:2:'
+ cycle GET_ARGS
+ !--------------
+ elseif(pointer<0)then
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:UNKNOWNSHORT_CONFIRMED:',letter
+ call print_dictionary('UNKNOWNSHORT KEYWORD:'//current_argument_padded(2:))
+ if(G_QUIET)then
+ lastkeyword="UNKNOWN"
+ pointer=0
+ cycle GET_ARGS
+ endif
+ call mystop(2)
+ return
+ endif
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:SHORT_END:1:'
+ lastkeyword=trim(current_argument_padded(2:))
+ next_mandatory=mandatory(pointer)
+ elseif(pointer == 0)then ! unnamed arguments
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:UNNAMEDARGUMENT:',current_argument
+ if(G_remaining_on)then
+ if(len(current_argument) < 1)then
+ G_remaining=G_remaining//'""'
+ elseif(current_argument(1:1) == '-')then
+ !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//''
+ G_remaining=G_remaining//'"'//current_argument//'"'
+ else
+ G_remaining=G_remaining//'"'//current_argument//'"'
+ endif
+ imax=max(len(args),len(current_argument))
+ args=[character(len=imax) :: args,current_argument]
+ else
+ imax=max(len(unnamed),len(current_argument))
+ if(scan(current_argument//'','@') == 1.and.G_response)then
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:1:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
+ call expand_response(current_argument)
+ else
+ unnamed=[character(len=imax) :: unnamed,current_argument]
+ endif
+ endif
+ else
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:FOUND:',current_argument
+ oldvalue=get(keywords(pointer))//''
+ if(oldvalue(1:1) == '"')then
+ current_argument=quote(current_argument(:ilength))
+ endif
+ if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter
+ if(current_argument /= ' ')then
+ if(G_remaining_on)then
+ if(len(current_argument) < 1)then
+ G_remaining=G_remaining//'"" '
+ elseif(current_argument(1:1) == '-')then
+ !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' '
+ G_remaining=G_remaining//'"'//current_argument//'" '
+ else
+ G_remaining=G_remaining//'"'//current_argument//'" '
+ endif
+ imax=max(len(args),len(current_argument))
+ args=[character(len=imax) :: args,current_argument]
+ else
+ imax=max(len(unnamed),len(current_argument))
+ if(scan(current_argument//' ','@') == 1.and.G_response)then
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
+ call expand_response(current_argument)
+ else
+ unnamed=[character(len=imax) :: unnamed,current_argument]
+ endif
+ endif
+ endif
+ current_argument='T'
+ endif
+ call update(keywords(pointer),current_argument)
+ pointer=0
+ lastkeyword=''
+ next_mandatory=.false.
+ endif
+ enddo GET_ARGS
+ if(lastkeyword /= '')then
+ call ifnull()
+ endif
+ if(G_DEBUG)write(*,gen)'<DEBUG>CMD_ARGS_TO_DICTIONARY:NORMAL END'
+
+contains
+
+subroutine ifnull()
+ oldvalue=get(lastkeyword)//' '
+ if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then
+ call update(lastkeyword,'T')
+ elseif(oldvalue(1:1) == '"')then
+ call update(lastkeyword,'" "')
+ else
+ call update(lastkeyword,'')
+ endif
+end subroutine ifnull
+
+function get_next_argument()
+!
+! get next argument from command line into allocated variable current_argument
+!
+logical,save :: hadequal=.false.
+character(len=:),allocatable,save :: right_hand_side
+logical :: get_next_argument
+integer :: iright
+integer :: iequal
+
+ if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax
+ current_argument=right_hand_side
+ right_hand_side=''
+ hadequal=.false.
+ get_next_argument=.true.
+ ilength=len(current_argument)
+ return
+ endif
+
+ if(i>command_argument_count())then
+ get_next_argument=.false.
+ return
+ else
+ get_next_argument=.true.
+ endif
+
+ call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument
+ if(istatus /= 0) then ! on error
+ write(warn,*)'*prototype_and_cmd_args_to_nlist*errorobtainingargument',i,&
+ &'status=',istatus,&
+ &'length=',ilength
+ get_next_argument=.false.
+ else
+ ilength=max(ilength,1)
+ if(allocated(current_argument))deallocate(current_argument)
+ allocate(character(len=ilength) :: current_argument)
+ call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument
+ if(istatus /= 0) then ! on error
+ write(warn,*)'*prototype_and_cmd_args_to_nlist*errorobtainingargument',i,&
+ &'status=',istatus,&
+ &'length=',ilength,&
+ &'target length=',len(current_argument)
+ get_next_argument=.false.
+ endif
+
+ ! if an argument keyword and an equal before a space split on equal and save right hand side for next call
+ if(nomore)then
+ elseif( len(current_argument) == 0)then
+ else
+ iright=index(current_argument,'')
+ if(iright == 0)iright=len(current_argument)
+ iequal=index(current_argument(:iright),'=')
+ if(next_mandatory)then
+ elseif(iequal /= 0.and.current_argument(1:1) == '-')then
+ if(iequal /= len(current_argument))then
+ right_hand_side=current_argument(iequal+1:)
+ else
+ right_hand_side=''
+ endif
+ hadequal=.true.
+ current_argument=current_argument(:iequal-1)
+ endif
+ endif
+ endif
+ i=i+1
+end function get_next_argument
+
+end subroutine cmd_args_to_dictionary
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary
+!! created by calls to set_args(3f)
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! subroutine print_dictionary(header,stop)
+!!
+!! character(len=*),intent(in),optional :: header
+!! logical,intent(in),optional :: stop
+!!##DESCRIPTION
+!! Print the internal dictionary created by calls to set_args(3f).
+!! This routine is intended to print the state of the argument list
+!! if an error occurs in using the set_args(3f) procedure.
+!!##OPTIONS
+!! HEADER label to print before printing the state of the command
+!! argument list.
+!! STOP logical value that if true stops the program after displaying
+!! the dictionary.
+!!##EXAMPLE
+!!
+!!
+!!
+!! Typical usage:
+!!
+!! program demo_print_dictionary
+!! use M_CLI2, only : set_args, get_args
+!! implicit none
+!! real :: x, y, z
+!! call set_args('-x10-y20-z30')
+!! call get_args('x',x,'y',y,'z',z)
+!! ! all done cracking the command line; use the values in your program.
+!! write(*,*)x,y,z
+!! end program demo_print_dictionary
+!!
+!! Sample output
+!!
+!! Calling the sample program with an unknown parameter or the --usage
+!! switch produces the following:
+!!
+!! $ ./demo_print_dictionary -A
+!! UNKNOWN SHORT KEYWORD: -A
+!! KEYWORD PRESENT VALUE
+!! z F [3]
+!! y F [2]
+!! x F [1]
+!! help F [F]
+!! version F [F]
+!! usage F [F]
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine print_dictionary(header,stop)
+character(len=*),intent(in),optional :: header
+logical,intent(in),optional :: stop
+integer :: i
+ if(G_QUIET)return
+ if(present(header))then
+ if(header /= '')then
+ write(warn,'(a)')header
+ endif
+ endif
+ if(allocated(keywords))then
+ if(size(keywords) > 0)then
+ write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE'
+ write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))') &
+ & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1)
+ endif
+ endif
+ if(allocated(unnamed))then
+ if(size(unnamed) > 0)then
+ write(warn,'(a)')'UNNAMED'
+ write(warn,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
+ endif
+ endif
+ if(allocated(args))then
+ if(size(args) > 0)then
+ write(warn,'(a)')'ARGS'
+ write(warn,'(i6.6,3a)')(i,'[',args(i),']',i=1,size(args))
+ endif
+ endif
+ if(G_remaining /= '')then
+ write(warn,'(a)')'REMAINING'
+ write(warn,'(a)')G_remaining
+ endif
+ if(present(stop))then
+ if(stop) call mystop(5)
+ endif
+end subroutine print_dictionary
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing
+!! command line arguments
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! get_args(3f) and its convenience functions:
+!!
+!! use M_CLI2, only : get_args
+!! ! convenience functions
+!! use M_CLI2, only : dget, iget, lget, rget, sget, cget
+!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
+!!
+!! subroutine get_args(name,value,delimiters)
+!!
+!! character(len=*),intent(in) :: name
+!!
+!! type(${TYPE}),allocatable,intent(out) :: value(:)
+!! ! or
+!! type(${TYPE}),allocatable,intent(out) :: value
+!!
+!! character(len=*),intent(in),optional :: delimiters
+!!
+!! where ${TYPE} may be from the set
+!! {real,doubleprecision,integer,logical,complex,character(len=:)}
+!!##DESCRIPTION
+!!
+!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has
+!! been called to parse the command line. For fixed-length CHARACTER
+!! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! GET_ARGS_FIXED_SIZE(3f).
+!!
+!! As a convenience multiple pairs of keywords and variables may be
+!! specified if and only if all the values are scalars and the CHARACTER
+!! variables are fixed-length or pre-allocated.
+!!
+!!##OPTIONS
+!!
+!! NAME name of commandline argument to obtain the value of
+!! VALUE variable to hold returned value. The kind of the value
+!! is used to determine the type of returned value. May
+!! be a scalar or allocatable array. If type is CHARACTER
+!! the scalar must have an allocatable length.
+!! DELIMITERS By default the delimiter for array values are comma,
+!! colon, and whitespace. A string containing an alternate
+!! list of delimiter characters may be supplied.
+!!
+!!##CONVENIENCE FUNCTIONS
+!! There are convenience functions that are replacements for calls to
+!! get_args(3f) for each supported default intrinsic type
+!!
+!! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f),
+!! cget(3f)
+!! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f),
+!! sgets(3f), cgets(3f)
+!!
+!! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL,
+!! S for string (CHARACTER), and C for COMPLEX.
+!!
+!! If the functions are called with no argument they will return the
+!! UNNAMED array converted to the specified type.
+!!
+!!##EXAMPLE
+!!
+!!
+!! Sample program:
+!!
+!! program demo_get_args
+!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
+!! implicit none
+!! integer :: i
+!! ! Define ARGS
+!! real :: x, y, z
+!! real,allocatable :: p(:)
+!! character(len=:),allocatable :: title
+!! logical :: l, lbig
+!! ! Define and parse (to set initial values) command line
+!! ! o only quote strings and use double-quotes
+!! ! o set all logical values to F or T.
+!! call set_args('&
+!! & -x 1 -y 2 -z 3 &
+!! & -p -1,-2,-3 &
+!! & --title "my title" &
+!! & -l F -L F &
+!! & --label " " &
+!! & ')
+!! ! Assign values to elements
+!! ! Scalars
+!! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+!! ! Allocatable string
+!! call get_args('title',title)
+!! ! Allocatable arrays
+!! call get_args('p',p)
+!! ! Use values
+!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
+!! write(*,*)'p=',p
+!! write(*,*)'title=',title
+!! write(*,*)'l=',l
+!! write(*,*)'L=',lbig
+!! if(size(filenames) > 0)then
+!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
+!! endif
+!! end program demo_get_args
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+!>
+!!##NAME
+!! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values
+!! for fixed-length string when parsing command line
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine get_args_fixed_length(name,value)
+!!
+!! character(len=*),intent(in) :: name
+!! character(len=:),allocatable :: value
+!! character(len=*),intent(in),optional :: delimiters
+!!
+!!##DESCRIPTION
+!!
+!! get_args_fixed_length(3f) returns the value of a string
+!! keyword when the string value is a fixed-length CHARACTER
+!! variable.
+!!
+!!##OPTIONS
+!!
+!! NAME name of commandline argument to obtain the value of
+!!
+!! VALUE variable to hold returned value.
+!! Must be a fixed-length CHARACTER variable.
+!!
+!! DELIMITERS By default the delimiter for array values are comma,
+!! colon, and whitespace. A string containing an alternate
+!! list of delimiter characters may be supplied.
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_get_args_fixed_length
+!! use M_CLI2, only : set_args, get_args_fixed_length
+!! implicit none
+!!
+!! ! Define args
+!! character(len=80) :: title
+!! ! Parse command line
+!! call set_args(' --title "my title" ')
+!! ! Assign values to variables
+!! call get_args_fixed_length('title',title)
+!! ! Use values
+!! write(*,*)'title=',title
+!!
+!! end program demo_get_args_fixed_length
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+!>
+!!##NAME
+!! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values
+!! for fixed-size array when parsing command line arguments
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine get_args_fixed_size(name,value)
+!!
+!! character(len=*),intent(in) :: name
+!! [real|doubleprecision|integer|logical|complex] :: value(NNN)
+!! or
+!! character(len=MMM) :: value(NNN)
+!!
+!! character(len=*),intent(in),optional :: delimiters
+!!
+!!##DESCRIPTION
+!!
+!! get_args_fixed_size(3f) returns the value of keywords for fixed-size
+!! arrays after set_args(3f) has been called. On input on the command
+!! line all values of the array must be specified.
+!!
+!!##OPTIONS
+!! NAME name of commandline argument to obtain the value of
+!!
+!! VALUE variable to hold returned values. The kind of the value
+!! is used to determine the type of returned value. Must be
+!! a fixed-size array. If type is CHARACTER the length must
+!! also be fixed.
+!!
+!! DELIMITERS By default the delimiter for array values are comma,
+!! colon, and whitespace. A string containing an alternate
+!! list of delimiter characters may be supplied.
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_get_args_fixed_size
+!! use M_CLI2, only : set_args, get_args_fixed_size
+!! implicit none
+!! integer,parameter :: dp=kind(0.0d0)
+!! ! DEFINE ARGS
+!! real :: x(2)
+!! real(kind=dp) :: y(2)
+!! integer :: p(3)
+!! character(len=80) :: title(1)
+!! logical :: l(4), lbig(4)
+!! complex :: cmp(2)
+!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+!! ! o only quote strings
+!! ! o set all logical values to F or T.
+!! call set_args(' &
+!! & -x 10.0,20.0 &
+!! & -y 11.0,22.0 &
+!! & -p -1,-2,-3 &
+!! & --title "my title" &
+!! & -l F,T,F,T -L T,F,T,F &
+!! & --cmp 111,222.0,333.0e0,4444 &
+!! & ')
+!! ! ASSIGN VALUES TO ELEMENTS
+!! call get_args_fixed_size('x',x)
+!! call get_args_fixed_size('y',y)
+!! call get_args_fixed_size('p',p)
+!! call get_args_fixed_size('title',title)
+!! call get_args_fixed_size('l',l)
+!! call get_args_fixed_size('L',lbig)
+!! call get_args_fixed_size('cmp',cmp)
+!! ! USE VALUES
+!! write(*,*)'x=',x
+!! write(*,*)'p=',p
+!! write(*,*)'title=',title
+!! write(*,*)'l=',l
+!! write(*,*)'L=',lbig
+!! write(*,*)'cmp=',cmp
+!! end program demo_get_args_fixed_size
+!! Results:
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+subroutine get_fixedarray_class(keyword,generic,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+class(*)::generic(:)
+character(len=*),intent(in),optional::delimiters
+select type(generic)
+type is(character(len=*));call get_fixedarray_fixed_length_c(keyword,generic,delimiters)
+type is(integer);call get_fixedarray_i(keyword,generic,delimiters)
+type is(real);call get_fixedarray_r(keyword,generic,delimiters)
+type is(complex);call get_fixed_size_complex(keyword,generic,delimiters)
+type is(real(kind=dp));call get_fixedarray_d(keyword,generic,delimiters)
+type is(logical);call get_fixedarray_l(keyword,generic,delimiters)
+class default
+call mystop(-7,'*get_fixedarray_class* crud -- procedure does not know about this type')
+end select
+end subroutine get_fixedarray_class
+!===================================================================================================================================
+! return allocatable arrays
+!===================================================================================================================================
+subroutine get_anyarray_l(keyword,larray,delimiters)
+
+! ident_5="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)"
+
+character(len=*),intent(in)::keyword! the dictionary keyword (in form VERB_KEYWORD) to retrieve
+logical,allocatable::larray(:)! convert value to an array
+character(len=*),intent(in),optional::delimiters
+character(len=:),allocatable::carray(:)! convert value to an array
+character(len=:),allocatable::val
+integer::i
+integer::place
+integer::iichar! point to first character of word unless first character is "."
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if string was found
+val=values(place)(:counts(place))
+call split(adjustl(upper(val)),carray,delimiters=delimiters)! convert value to uppercase, trimmed; then parse into array
+else
+ call journal('*get_anyarray_l* unknown keyword',keyword)
+call mystop(8,'*get_anyarray_l* unknown keyword '//keyword)
+if(allocated(larray))deallocate(larray)
+allocate(larray(0))
+return
+ endif
+ if(size(carray)>0)then! if not a null string
+if(allocated(larray))deallocate(larray)
+allocate(larray(size(carray)))! allocate output array
+do i=1,size(carray)
+larray(i)=.false.! initialize return value to .false.
+if(carray(i)(1:1)=='.')then! looking for fortran logical syntax .STRING.
+iichar=2
+else
+iichar=1
+endif
+ select case(carray(i)(iichar:iichar))! check word to see if true or false
+case('T','Y',' ');larray(i)=.true.! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
+case('F','N');larray(i)=.false.! assume this is false or no
+case default
+call journal("*get_anyarray_l* bad logical expression for ",(keyword),'=',carray(i))
+end select
+ enddo
+ else! for a blank string return one T
+if(allocated(larray))deallocate(larray)
+allocate(larray(1))! allocate output array
+larray(1)=.true.
+endif
+end subroutine get_anyarray_l
+!===================================================================================================================================
+subroutine get_anyarray_d(keyword,darray,delimiters)
+
+! ident_6="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)"
+
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real(kind=dp),allocatable,intent(out)::darray(:)! function type
+character(len=*),intent(in),optional::delimiters
+
+character(len=:),allocatable::carray(:)! convert value to an array using split(3f)
+integer::i
+integer::place
+integer::ierr
+character(len=:),allocatable::val
+!-----------------------------------------------------------------------------------------------------------------------------------
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if string was found
+val=values(place)(:counts(place))
+val=replace_str(val,'(','')
+val=replace_str(val,')','')
+call split(val,carray,delimiters=delimiters)! find value associated with keyword and split it into an array
+else
+ call journal('*get_anyarray_d* unknown keyword '//keyword)
+call mystop(9,'*get_anyarray_d* unknown keyword '//keyword)
+if(allocated(darray))deallocate(darray)
+allocate(darray(0))
+return
+ endif
+ if(allocated(darray))deallocate(darray)
+allocate(darray(size(carray)))! create the output array
+do i=1,size(carray)
+call a2d(carray(i),darray(i),ierr)! convert the string to a numeric value
+if(ierr/=0)then
+ call mystop(10,'*get_anyarray_d* unreadable value '//carray(i)//' for keyword '//keyword)
+endif
+ enddo
+end subroutine get_anyarray_d
+!===================================================================================================================================
+subroutine get_anyarray_i(keyword,iarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+integer,allocatable::iarray(:)
+character(len=*),intent(in),optional::delimiters
+real(kind=dp),allocatable::darray(:)! function type
+call get_anyarray_d(keyword,darray,delimiters)
+iarray=nint(darray)
+end subroutine get_anyarray_i
+!===================================================================================================================================
+subroutine get_anyarray_r(keyword,rarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real,allocatable::rarray(:)
+character(len=*),intent(in),optional::delimiters
+real(kind=dp),allocatable::darray(:)! function type
+call get_anyarray_d(keyword,darray,delimiters)
+rarray=real(darray)
+end subroutine get_anyarray_r
+!===================================================================================================================================
+subroutine get_anyarray_x(keyword,xarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+complex(kind=sp),allocatable::xarray(:)
+character(len=*),intent(in),optional::delimiters
+real(kind=dp),allocatable::darray(:)! function type
+integer::half,sz,i
+call get_anyarray_d(keyword,darray,delimiters)
+sz=size(darray)
+half=sz/2
+if(sz/=half+half)then
+ call journal('*get_anyarray_x* uneven number of values defining complex value '//keyword)
+call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword)
+if(allocated(xarray))deallocate(xarray)
+allocate(xarray(0))
+endif
+
+!x!================================================================================================
+!x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2)))
+if(allocated(xarray))deallocate(xarray)
+allocate(xarray(half))
+do i=1,sz,2
+xarray((i+1)/2)=cmplx(darray(i),darray(i+1),kind=sp)
+enddo
+!x!================================================================================================
+
+end subroutine get_anyarray_x
+!===================================================================================================================================
+subroutine get_anyarray_c(keyword,strings,delimiters)
+
+! ident_8="@(#)M_CLI2::get_anyarray_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary"
+
+! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
+character(len=*),intent(in)::keyword! name to look up in dictionary
+character(len=:),allocatable::strings(:)
+character(len=*),intent(in),optional::delimiters
+integer::place
+character(len=:),allocatable::val
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if index is valid return strings
+val=unquote(values(place)(:counts(place)))
+call split(val,strings,delimiters=delimiters)! find value associated with keyword and split it into an array
+else
+ call journal('*get_anyarray_c* unknown keyword '//keyword)
+call mystop(12,'*get_anyarray_c* unknown keyword '//keyword)
+if(allocated(strings))deallocate(strings)
+allocate(character(len=0)::strings(0))
+endif
+end subroutine get_anyarray_c
+!===================================================================================================================================
+!===================================================================================================================================
+subroutine get_args_fixed_length_a_array(keyword,strings,delimiters)
+
+! ident_7="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
+
+! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
+character(len=*),intent(in)::keyword! name to look up in dictionary
+character(len=*),allocatable::strings(:)
+character(len=*),intent(in),optional::delimiters
+character(len=:),allocatable::strings_a(:)
+integer::place
+character(len=:),allocatable::val
+integer::ibug
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if index is valid return strings
+val=unquote(values(place)(:counts(place)))
+call split(val,strings_a,delimiters=delimiters)! find value associated with keyword and split it into an array
+if(len(strings_a)<=len(strings))then
+strings=strings_a
+else
+ibug=len(strings)
+call journal('*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug)
+write(*,'("strings=",3x,*(a,1x))')strings
+call journal('*get_args_fixed_length_a_array* keyword='//keyword)
+call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword)
+strings=[character(len=len(strings))::]
+endif
+ else
+ call journal('*get_args_fixed_length_a_array* unknown keyword '//keyword)
+call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword)
+strings=[character(len=len(strings))::]
+endif
+end subroutine get_args_fixed_length_a_array
+!===================================================================================================================================
+! return non-allocatable arrays
+!===================================================================================================================================
+subroutine get_fixedarray_i(keyword,iarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+integer::iarray(:)
+character(len=*),intent(in),optional::delimiters
+real(kind=dp),allocatable::darray(:)! function type
+integer::dsize
+integer::ibug
+call get_anyarray_d(keyword,darray,delimiters)
+dsize=size(darray)
+if(ubound(iarray,dim=1)==dsize)then
+iarray=nint(darray)
+else
+ibug=size(iarray)
+call journal('*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+call print_dictionary('USAGE:')
+call mystop(33)
+iarray=0
+endif
+end subroutine get_fixedarray_i
+!===================================================================================================================================
+subroutine get_fixedarray_r(keyword,rarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real::rarray(:)
+character(len=*),intent(in),optional::delimiters
+real,allocatable::darray(:)! function type
+integer::dsize
+integer::ibug
+call get_anyarray_r(keyword,darray,delimiters)
+dsize=size(darray)
+if(ubound(rarray,dim=1)==dsize)then
+rarray=darray
+else
+ibug=size(rarray)
+call journal('*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+call print_dictionary('USAGE:')
+call mystop(33)
+rarray=0.0
+endif
+end subroutine get_fixedarray_r
+!===================================================================================================================================
+subroutine get_fixed_size_complex(keyword,xarray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+complex::xarray(:)
+character(len=*),intent(in),optional::delimiters
+complex,allocatable::darray(:)! function type
+integer::half,sz
+integer::dsize
+integer::ibug
+call get_anyarray_x(keyword,darray,delimiters)
+dsize=size(darray)
+sz=dsize*2
+half=sz/2
+if(sz/=half+half)then
+ call journal('*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
+call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
+xarray=0
+return
+ endif
+ if(ubound(xarray,dim=1)==dsize)then
+xarray=darray
+else
+ibug=size(xarray)
+call journal('*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+call print_dictionary('USAGE:')
+call mystop(34)
+xarray=cmplx(0.0,0.0)
+endif
+end subroutine get_fixed_size_complex
+!===================================================================================================================================
+subroutine get_fixedarray_d(keyword,darr,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real(kind=dp)::darr(:)
+character(len=*),intent(in),optional::delimiters
+real(kind=dp),allocatable::darray(:)! function type
+integer::dsize
+integer::ibug
+call get_anyarray_d(keyword,darray,delimiters)
+dsize=size(darray)
+if(ubound(darr,dim=1)==dsize)then
+darr=darray
+else
+ibug=size(darr)
+call journal('*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+call print_dictionary('USAGE:')
+call mystop(35)
+darr=0.0d0
+endif
+end subroutine get_fixedarray_d
+!===================================================================================================================================
+subroutine get_fixedarray_l(keyword,larray,delimiters)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+logical::larray(:)
+character(len=*),intent(in),optional::delimiters
+logical,allocatable::darray(:)! function type
+integer::dsize
+integer::ibug
+call get_anyarray_l(keyword,darray,delimiters)
+dsize=size(darray)
+if(ubound(larray,dim=1)==dsize)then
+larray=darray
+else
+ibug=size(larray)
+call journal('*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+call print_dictionary('USAGE:')
+call mystop(36)
+larray=.false.
+endif
+end subroutine get_fixedarray_l
+!===================================================================================================================================
+subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters)
+
+! ident_8="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
+
+! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
+character(len=*)::strings(:)
+character(len=*),intent(in),optional::delimiters
+character(len=:),allocatable::str(:)
+character(len=*),intent(in)::keyword! name to look up in dictionary
+integer::place
+integer::ssize
+integer::ibug
+character(len=:),allocatable::val
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if index is valid return strings
+val=unquote(values(place)(:counts(place)))
+call split(val,str,delimiters=delimiters)! find value associated with keyword and split it into an array
+ssize=size(str)
+if(ssize==size(strings))then
+strings(:ssize)=str
+else
+ibug=size(strings)
+call journal('*get_fixedarray_fixed_length_c* wrong number of values for keyword',&
+&keyword,'got',ssize,'expected ',ibug)!,ubound(strings,dim=1)
+call print_dictionary('USAGE:')
+call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
+strings=''
+endif
+ else
+ call journal('*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
+call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
+strings=''endif
-end subroutine get_scalar_anylength_c
+end subroutine get_fixedarray_fixed_length_c!===================================================================================================================================
-elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string)
-
-! ident_12="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
-
-! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
-character(len=*),intent(in)::keyword! name to look up in dictionary
-character(len=*),intent(out)::string
-integer::place
-integer::unlen
-integer::ibug
-call locate_key(keyword,place)! find where string is or should be
-if(place>0)then! if index is valid return string
-string=unquote(values(place)(:counts(place)))
-else
- call mystop(18,'*get_args_fixed_length_scalar_c* unknown keyword '//keyword)
-string=''
-endif
-unlen=len_trim(unquote(values(place)(:counts(place))))
-if(unlen>len(string))then
-ibug=len(string)
-call journal('sc','*get_args_fixed_length_scalar_c* value too long for',keyword,'allowed is',ibug,&
-&'input string [',values(place),'] is',unlen)
-call mystop(19,'*get_args_fixed_length_scalar_c* value too long')
-string=''
-endif
-end subroutine get_args_fixed_length_scalar_c
-!===================================================================================================================================
-subroutine get_scalar_complex(keyword,x)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-complex,intent(out)::x
-real(kind=dp)::d(2)
-call get_fixedarray_d(keyword,d)
-x=cmplx(d(1),d(2),kind=sp)
-end subroutine get_scalar_complex
-!===================================================================================================================================
-subroutine get_scalar_logical(keyword,l)
-character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
-logical::l
-logical,allocatable::larray(:)! function type
-integer::ibug
-l=.false.
-call get_anyarray_l(keyword,larray)
-if(.not.allocated(larray))then
- call journal('sc','*get_scalar_logical* expected one value found not allocated')
-call mystop(37,'*get_scalar_logical* incorrect number of values for keyword '//keyword)
-elseif(size(larray)==1)then
-l=larray(1)
-else
-ibug=size(larray)
-call journal('sc','*get_scalar_logical* expected one value found',ibug)
-call mystop(21,'*get_scalar_logical* incorrect number of values for keyword '//keyword)
-endif
-end subroutine get_scalar_logical
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE
-!use M_list, only : insert, locate, remove, replace
-!use M_journal, only : JOURNAL
-
-!use M_args, only : LONGEST_COMMAND_ARGUMENT
-! routines extracted from other modules
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest
-!! argument on command line
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! function longest_command_argument() result(ilongest)
-!!
-!! integer :: ilongest
-!!
-!!##DESCRIPTION
-!! length of longest argument on command line. Useful when allocating
-!! storage for holding arguments.
-!!##RESULT
-!! longest_command_argument length of longest command argument
-!!##EXAMPLE
-!!
-!! Sample program
-!!
-!! program demo_longest_command_argument
-!! use M_args, only : longest_command_argument
-!! write(*,*)'longest argument is ',longest_command_argument()
-!! end program demo_longest_command_argument
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-function longest_command_argument()result(ilongest)
-integer::i
-integer::ilength
-integer::istatus
-integer::ilongest
-ilength=0
-ilongest=0
-GET_LONGEST:do i=1,command_argument_count()! loop throughout command line arguments to find longest
-call get_command_argument(number=i,length=ilength,status=istatus)! get next argument
-if(istatus/=0)then! on error
-write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining length for argument ',i
-exit GET_LONGEST
-elseif(ilength>0)then
-ilongest=max(ilongest,ilength)
-endif
- enddo GET_LONGEST
-end function longest_command_argument
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-subroutine journal(where,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
-
-! ident_13="@(#) M_CLI2 journal(3f) writes a message to a string composed of any standard scalar types"
-
-character(len=*),intent(in)::where
-class(*),intent(in)::g0
-class(*),intent(in),optional::g1,g2,g3,g4,g5,g6,g7,g8,g9
-class(*),intent(in),optional::ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
-character(len=*),intent(in),optional::sep
-write(*,'(a)')str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
-end subroutine journal
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! str(3f) - [M_CLI2] converts any standard scalar type to a string
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
+! return scalars
+!===================================================================================================================================
+subroutine get_scalar_d(keyword,d)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real(kind=dp)::d
+real(kind=dp),allocatable::darray(:)! function type
+integer::ibug
+call get_anyarray_d(keyword,darray)
+if(size(darray)==1)then
+d=darray(1)
+else
+ibug=size(darray)
+call journal('*get_anyarray_d* incorrect number of values for keyword "',keyword,'" expected one found',ibug)
+call print_dictionary('USAGE:')
+call mystop(31,'*get_anyarray_d* incorrect number of values for keyword "'//keyword//'" expected one')
+endif
+end subroutine get_scalar_d
+!===================================================================================================================================
+subroutine get_scalar_real(keyword,r)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+real,intent(out)::r
+real(kind=dp)::d
+call get_scalar_d(keyword,d)
+r=real(d)
+end subroutine get_scalar_real
+!===================================================================================================================================
+subroutine get_scalar_i(keyword,i)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+integer,intent(out)::i
+real(kind=dp)::d
+call get_scalar_d(keyword,d)
+i=nint(d)
+end subroutine get_scalar_i
+!===================================================================================================================================
+subroutine get_scalar_anylength_c(keyword,string)
+
+! ident_9="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
+
+! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
+character(len=*),intent(in)::keyword! name to look up in dictionary
+character(len=:),allocatable,intent(out)::string
+integer::place
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if index is valid return string
+string=unquote(values(place)(:counts(place)))
+else
+ call mystop(17,'*get_anyarray_c* unknown keyword '//keyword)
+call journal('*get_anyarray_c* unknown keyword '//keyword)
+string=''
+endif
+end subroutine get_scalar_anylength_c
+!===================================================================================================================================
+elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string)
+
+! ident_10="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
+
+! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
+character(len=*),intent(in)::keyword! name to look up in dictionary
+character(len=*),intent(out)::string
+integer::place
+integer::unlen
+integer::ibug
+call locate_key(keyword,place)! find where string is or should be
+if(place>0)then! if index is valid return string
+string=unquote(values(place)(:counts(place)))
+else
+ call mystop(18,'*get_args_fixed_length_scalar_c* unknown keyword '//keyword)
+string=''
+endif
+unlen=len_trim(unquote(values(place)(:counts(place))))
+if(unlen>len(string))then
+ibug=len(string)
+call journal('*get_args_fixed_length_scalar_c* value too long for',keyword,'allowed is',ibug,&
+&'input string [',values(place),'] is',unlen)
+call mystop(19,'*get_args_fixed_length_scalar_c* value too long')
+string=''
+endif
+end subroutine get_args_fixed_length_scalar_c
+!===================================================================================================================================
+subroutine get_scalar_complex(keyword,x)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+complex,intent(out)::x
+real(kind=dp)::d(2)
+call get_fixedarray_d(keyword,d)
+x=cmplx(d(1),d(2),kind=sp)
+end subroutine get_scalar_complex
+!===================================================================================================================================
+subroutine get_scalar_logical(keyword,l)
+character(len=*),intent(in)::keyword! keyword to retrieve value from dictionary
+logical::l
+logical,allocatable::larray(:)! function type
+integer::ibug
+l=.false.
+call get_anyarray_l(keyword,larray)
+if(.not.allocated(larray))then
+ call journal('*get_scalar_logical* expected one value found not allocated')
+call mystop(37,'*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"')
+elseif(size(larray)==1)then
+l=larray(1)
+else
+ibug=size(larray)
+call journal('*get_scalar_logical* expected one value found',ibug)
+call mystop(21,'*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"')
+endif
+end subroutine get_scalar_logical
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE
+!use M_list, only : insert, locate, remove, replace
+!use M_journal, only : JOURNAL
+
+!use M_args, only : LONGEST_COMMAND_ARGUMENT
+! routines extracted from other modules
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest
+!! argument on command line
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! function longest_command_argument() result(ilongest)
+!!
+!! integer :: ilongest
+!!
+!!##DESCRIPTION
+!! length of longest argument on command line. Useful when allocating
+!! storage for holding arguments.
+!!##RESULT
+!! longest_command_argument length of longest command argument
+!!##EXAMPLE!!
-!! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
-!! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
-!! character(len=*),intent(in),optional :: sep
-!! character,len=(:),allocatable :: str
-!!
-!!##DESCRIPTION
-!! str(3f) builds a space-separated string from up to twenty scalar values.
-!!
-!!##OPTIONS
-!! g[0-9a-j] optional value to print the value of after the message. May
-!! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
-!! COMPLEX, or CHARACTER.
-!!
-!! Optionally, all the generic values can be
-!! single-dimensioned arrays. Currently, mixing scalar
-!! arguments and array arguments is not supported.
-!!
-!! sep separator to place between values. Defaults to a space.
-!!##RETURNS
-!! str description to print
-!!##EXAMPLES
-!!
-!! Sample program:
-!!
-!! program demo_str
-!! use M_CLI2, only : str
-!! implicit none
-!! character(len=:),allocatable :: pr
-!! character(len=:),allocatable :: frmt
-!! integer :: biggest
-!!
-!! pr=str('HUGE(3f) integers',huge(0),'and real',&
-!! & huge(0.0),'and double',huge(0.0d0))
-!! write(*,'(a)')pr
-!! pr=str('real :',huge(0.0),0.0,12345.6789,tiny(0.0) )
-!! write(*,'(a)')pr
-!! pr=str('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) )
-!! write(*,'(a)')pr
-!! pr=str('complex :',cmplx(huge(0.0),tiny(0.0)) )
-!! write(*,'(a)')pr
-!!
-!! ! create a format on the fly
-!! biggest=huge(0)
-!! frmt=str('(*(i',nint(log10(real(biggest))),':,1x))',sep=' ')
-!! write(*,*)'format=',frmt
-!!
-!! ! although it will often work, using str(3f) in an I/O statement
-!! ! is not recommended because if an error occurs str(3f) will try
-!! ! to write while part of an I/O statement which not all compilers
-!! ! can handle and is currently non-standard
-!! write(*,*)str('program will now stop')
-!!
-!! end program demo_str
-!!
-!! Output
-!!
-!! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and
-!! double 1.7976931348623157E+308
-!! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38
-!! doubleprecision : 1.7976931348623157E+308 0.0000000000000000
-!! 12345.678900000001 2.2250738585072014E-308
-!! complex : (3.40282347E+38,1.17549435E-38)
-!! format=(*(i9:,1x))
-!! program will now stop
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function msg_scalar(generic0,generic1,generic2,generic3,generic4,generic5,generic6,generic7,generic8,generic9,&
-&generica,genericb,genericc,genericd,generice,genericf,genericg,generich,generici,genericj,&
-&sep)
-
-! ident_14="@(#) M_CLI2 msg_scalar(3fp) writes a message to a string composed of any standard scalar types"
-
-class(*),intent(in),optional::generic0,generic1,generic2,generic3,generic4
-class(*),intent(in),optional::generic5,generic6,generic7,generic8,generic9
-class(*),intent(in),optional::generica,genericb,genericc,genericd,generice
-class(*),intent(in),optional::genericf,genericg,generich,generici,genericj
-character(len=*),intent(in),optional::sep
-character(len=:),allocatable::sep_local
-character(len=:),allocatable::msg_scalar
-character(len=4096)::line
-integer::istart
-integer::increment
-if(present(sep))then
-sep_local=sep
-increment=len(sep_local)+1
-else
-sep_local=' '
-increment=2
-endif
-
-istart=1
-line=''
-if(present(generic0))call print_generic(generic0)
-if(present(generic1))call print_generic(generic1)
-if(present(generic2))call print_generic(generic2)
-if(present(generic3))call print_generic(generic3)
-if(present(generic4))call print_generic(generic4)
-if(present(generic5))call print_generic(generic5)
-if(present(generic6))call print_generic(generic6)
-if(present(generic7))call print_generic(generic7)
-if(present(generic8))call print_generic(generic8)
-if(present(generic9))call print_generic(generic9)
-if(present(generica))call print_generic(generica)
-if(present(genericb))call print_generic(genericb)
-if(present(genericc))call print_generic(genericc)
-if(present(genericd))call print_generic(genericd)
-if(present(generice))call print_generic(generice)
-if(present(genericf))call print_generic(genericf)
-if(present(genericg))call print_generic(genericg)
-if(present(generich))call print_generic(generich)
-if(present(generici))call print_generic(generici)
-if(present(genericj))call print_generic(genericj)
-msg_scalar=trim(line)
-contains
-!===================================================================================================================================
-subroutine print_generic(generic)
-use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
-class(*),intent(in)::generic
- select type(generic)
-type is(integer(kind=int8));write(line(istart:),'(i0)')generic
- type is(integer(kind=int16));write(line(istart:),'(i0)')generic
- type is(integer(kind=int32));write(line(istart:),'(i0)')generic
- type is(integer(kind=int64));write(line(istart:),'(i0)')generic
- type is(real(kind=real32));write(line(istart:),'(1pg0)')generic
- type is(real(kind=real64))
-write(line(istart:),'(1pg0)')generic
-!x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic
-type is(logical)
-write(line(istart:),'(l1)')generic
- type is(character(len=*))
-write(line(istart:),'(a)')trim(generic)
-type is(complex);write(line(istart:),'("(",1pg0,",",1pg0,")")')generic
- end select
-istart=len_trim(line)+increment
-line=trim(line)//sep_local
-end subroutine print_generic
-!===================================================================================================================================
-end function msg_scalar
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function msg_one(generic0,generic1,generic2,generic3,generic4,generic5,generic6,generic7,generic8,generic9,sep)
-
-! ident_15="@(#) M_CLI2 msg_one(3fp) writes a message to a string composed of any standard one dimensional types"
-
-class(*),intent(in)::generic0(:)
-class(*),intent(in),optional::generic1(:),generic2(:),generic3(:),generic4(:),generic5(:)
-class(*),intent(in),optional::generic6(:),generic7(:),generic8(:),generic9(:)
-character(len=*),intent(in),optional::sep
-character(len=:),allocatable::sep_local
-character(len=:),allocatable::msg_one
-character(len=4096)::line
-integer::istart
-integer::increment
-if(present(sep))then
-sep_local=sep
-increment=len(sep_local)+1
-else
-sep_local=' '
-increment=2
-endif
-
-istart=1
-line=' '
-call print_generic(generic0)
-if(present(generic1))call print_generic(generic1)
-if(present(generic2))call print_generic(generic2)
-if(present(generic3))call print_generic(generic3)
-if(present(generic4))call print_generic(generic4)
-if(present(generic5))call print_generic(generic5)
-if(present(generic6))call print_generic(generic6)
-if(present(generic7))call print_generic(generic7)
-if(present(generic8))call print_generic(generic8)
-if(present(generic9))call print_generic(generic9)
-msg_one=trim(line)
-contains
-!===================================================================================================================================
-subroutine print_generic(generic)
-use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
-class(*),intent(in),optional::generic(:)
-integer::i
-select type(generic)
-type is(integer(kind=int8));write(line(istart:),'("[",*(i0,1x))')generic
- type is(integer(kind=int16));write(line(istart:),'("[",*(i0,1x))')generic
- type is(integer(kind=int32));write(line(istart:),'("[",*(i0,1x))')generic
- type is(integer(kind=int64));write(line(istart:),'("[",*(i0,1x))')generic
- type is(real(kind=real32));write(line(istart:),'("[",*(1pg0,1x))')generic
- type is(real(kind=real64));write(line(istart:),'("[",*(1pg0,1x))')generic
-!x! DOES NOT WORK WITH nvfortran: type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic
-!x! DOES NOT WORK WITH ifort: type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic
-type is(logical);write(line(istart:),'("[",*(l1,1x))')generic
- type is(character(len=*))
-write(line(istart:),'("[",:*("""",a,"""",1x))')(trim(generic(i)),i=1,size(generic))
-type is(complex);write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))')generic
- class default
-call mystop(-22,'unknown type in *print_generic*')
-end select
-istart=len_trim(line)+increment+1
-line=trim(line)//"]"//sep_local
-end subroutine print_generic
-!===================================================================================================================================
-end function msg_one
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function upper(str)result(string)
-
-! ident_16="@(#) M_CLI2 upper(3f) Changes a string to uppercase"
-
-character(*),intent(in)::str
-character(:),allocatable::string
-integer::i
-string=str
-do i=1,len_trim(str)
-select case(str(i:i))
-case('a':'z')
-string(i:i)=char(iachar(str(i:i))-32)
-end select
- end do
-end function upper
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function lower(str)result(string)
-
-! ident_17="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range"
-
-character(*),intent(In)::str
-character(:),allocatable::string
-integer::i
-string=str
-do i=1,len_trim(str)
-select case(str(i:i))
-case('A':'Z')
-string(i:i)=char(iachar(str(i:i))+32)
-end select
- end do
-end function lower
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-subroutine a2i(chars,valu,ierr)
-
-! ident_18="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string"
-
-character(len=*),intent(in)::chars! input string
-integer,intent(out)::valu! value read from input string
-integer,intent(out)::ierr! error flag (0 == no error)
-doubleprecision::valu8
-integer,parameter::ihuge=huge(0)
-valu8=0.0d0
-call a2d(chars,valu8,ierr,onerr=0.0d0)
-if(valu8<=huge(valu))then
- if(valu8<=huge(valu))then
-valu=int(valu8)
-else
- call journal('sc','*a2i*','- value too large',valu8,'>',ihuge)
-valu=huge(valu)
-ierr=-1
-endif
- endif
-end subroutine a2i
-!----------------------------------------------------------------------------------------------------------------------------------
-subroutine a2d(chars,valu,ierr,onerr)
-
-! ident_19="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string"
-
-! 1989,2016 John S. Urban.
-!
-! o works with any g-format input, including integer, real, and exponential.
-! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0.
-! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data.
-! IERR will still be non-zero in this case.
-!----------------------------------------------------------------------------------------------------------------------------------
-character(len=*),intent(in)::chars! input string
-character(len=:),allocatable::local_chars
-doubleprecision,intent(out)::valu! value read from input string
-integer,intent(out)::ierr! error flag (0 == no error)
-class(*),optional,intent(in)::onerr
-!----------------------------------------------------------------------------------------------------------------------------------
-character(len=*),parameter::fmt="('(bn,g',i5,'.0)')"! format used to build frmt
-character(len=15)::frmt! holds format built to read input string
-character(len=256)::msg! hold message from I/O errors
-integer::intg
-integer::pnd
-integer::basevalue,ivalu
-character(len=3),save::nan_string='NaN'
-!----------------------------------------------------------------------------------------------------------------------------------
-ierr=0! initialize error flag to zero
-local_chars=unquote(chars)
-msg=''
-if(len(local_chars)==0)local_chars=' '
-call substitute(local_chars,',','')! remove any comma characters
-pnd=scan(local_chars,'#:')
-if(pnd/=0)then
- write(frmt,fmt)pnd-1! build format of form '(BN,Gn.0)'
-read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue! try to read value from string
-if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then
-valu=real(ivalu,kind=kind(0.0d0))
-else
-valu=0.0d0
-ierr=-1
-endif
- else
- select case(local_chars(1:1))
-case('z','Z','h','H')! assume hexadecimal
-frmt='(Z'//i2s(len(local_chars))//')'
-read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
-valu=dble(intg)
-case('b','B')! assume binary (base 2)
-frmt='(B'//i2s(len(local_chars))//')'
-read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
-valu=dble(intg)
-case('o','O')! assume octal
-frmt='(O'//i2s(len(local_chars))//')'
-read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
-valu=dble(intg)
-case default
-write(frmt,fmt)len(local_chars)! build format of form '(BN,Gn.0)'
-read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu! try to read value from string
-end select
- endif
- if(ierr/=0)then! if an error occurred ierr will be non-zero.
-if(present(onerr))then
- select type(onerr)
-type is(integer)
-valu=onerr
-type is(real)
-valu=onerr
-type is(doubleprecision)
-valu=onerr
-end select
- else! set return value to NaN
-read(nan_string,'(f3.3)')valu
-endif
- if(local_chars/='eod')then! print warning message except for special value "eod"
-call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']')
-if(msg/='')then
- call journal('sc','*a2d* - ['//trim(msg)//']')
-endif
- endif
- endif
-end subroutine a2d
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified
-!! delimiters
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine split(input_line,array,delimiters,order,nulls)
-!!
-!! character(len=*),intent(in) :: input_line
-!! character(len=:),allocatable,intent(out) :: array(:)
-!! character(len=*),optional,intent(in) :: delimiters
-!! character(len=*),optional,intent(in) :: order
-!! character(len=*),optional,intent(in) :: nulls
-!!##DESCRIPTION
-!! SPLIT(3f) parses a string using specified delimiter characters and
-!! store tokens into an allocatable array
-!!
-!!##OPTIONS
-!!
-!! INPUT_LINE Input string to tokenize
-!!
-!! ARRAY Output array of tokens
-!!
-!! DELIMITERS List of delimiter characters.
-!! The default delimiters are the "whitespace" characters
-!! (space, tab,new line, vertical tab, formfeed, carriage
-!! return, and null). You may specify an alternate set of
-!! delimiter characters.
+!! Sample program
+!!
+!! program demo_longest_command_argument
+!! use M_args, only : longest_command_argument
+!! write(*,*)'longest argument is ',longest_command_argument()
+!! end program demo_longest_command_argument
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+function longest_command_argument()result(ilongest)
+integer::i
+integer::ilength
+integer::istatus
+integer::ilongest
+ilength=0
+ilongest=0
+GET_LONGEST:do i=1,command_argument_count()! loop throughout command line arguments to find longest
+call get_command_argument(number=i,length=ilength,status=istatus)! get next argument
+if(istatus/=0)then! on error
+write(warn,*)'*prototype_and_cmd_args_to_nlist* error obtaining length for argument ',i
+exit GET_LONGEST
+elseif(ilength>0)then
+ilongest=max(ilongest,ilength)
+endif
+ enddo GET_LONGEST
+end function longest_command_argument
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
+!!
+!! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
+!! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
+!! character(len=*),intent(in),optional :: sep
+!!
+!!##DESCRIPTION
+!! journal(3f) builds and prints a space-separated string from up to twenty scalar values.
+!!
+!!##OPTIONS
+!! g[0-9a-j] optional value to print the value of after the message. May
+!! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
+!! COMPLEX, or CHARACTER.
+!!
+!! sep separator to place between values. Defaults to a space.
+!!##RETURNS
+!! journal description to print
+!!##EXAMPLES
+!!
+!! Sample program:
+!!
+!! program demo_journal
+!! use M_CLI2, only : journal
+!! implicit none
+!! character(len=:),allocatable :: frmt
+!! integer :: biggest
+!!
+!! call journal('HUGE(3f) integers',huge(0),'and real',&
+!! & huge(0.0),'and double',huge(0.0d0))
+!! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) )
+!! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) )
+!! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) )
+!!
+!! end program demo_journal
+!!
+!! Output
+!!
+!! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and
+!! double 1.7976931348623157E+308
+!! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38
+!! doubleprecision : 1.7976931348623157E+308 0.0000000000000000
+!! 12345.678900000001 2.2250738585072014E-308
+!! complex : (3.40282347E+38,1.17549435E-38)
+!! format=(*(i9:,1x))
+!! program will now stop
+!!
+!!##AUTHOR
+!! John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
+
+! ident_11="@(#) M_CLI2 journal(3fp) writes a message to a string composed of any standard scalar types"
+
+class(*),intent(in),optional::g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
+character(len=*),intent(in),optional::sep
+character(len=:),allocatable::sep_local
+character(len=4096)::line
+integer::istart
+integer::increment
+if(present(sep))then
+sep_local=sep
+increment=len(sep_local)+1
+else
+sep_local=' '
+increment=2
+endif
+
+istart=1
+line=''
+if(present(g0))call print_generic(g0)
+if(present(g1))call print_generic(g1)
+if(present(g2))call print_generic(g2)
+if(present(g3))call print_generic(g3)
+if(present(g4))call print_generic(g4)
+if(present(g5))call print_generic(g5)
+if(present(g6))call print_generic(g6)
+if(present(g7))call print_generic(g7)
+if(present(g8))call print_generic(g8)
+if(present(g9))call print_generic(g9)
+if(present(ga))call print_generic(ga)
+if(present(gb))call print_generic(gb)
+if(present(gc))call print_generic(gc)
+if(present(gd))call print_generic(gd)
+if(present(ge))call print_generic(ge)
+if(present(gf))call print_generic(gf)
+if(present(gg))call print_generic(gg)
+if(present(gh))call print_generic(gh)
+if(present(gi))call print_generic(gi)
+if(present(gj))call print_generic(gj)
+write(*,'(a)')trim(line)
+contains
+!===================================================================================================================================
+subroutine print_generic(generic)
+use,intrinsic::iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
+class(*),intent(in)::generic
+ select type(generic)
+type is(integer(kind=int8));write(line(istart:),'(i0)')generic
+ type is(integer(kind=int16));write(line(istart:),'(i0)')generic
+ type is(integer(kind=int32));write(line(istart:),'(i0)')generic
+ type is(integer(kind=int64));write(line(istart:),'(i0)')generic
+ type is(real(kind=real32));write(line(istart:),'(1pg0)')generic
+ type is(real(kind=real64))
+write(line(istart:),'(1pg0)')generic
+!x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic
+type is(logical)
+write(line(istart:),'(l1)')generic
+ type is(character(len=*))
+write(line(istart:),'(a)')trim(generic)
+type is(complex);write(line(istart:),'("(",1pg0,",",1pg0,")")')generic
+ end select
+istart=len_trim(line)+increment
+line=trim(line)//sep_local
+end subroutine print_generic
+!===================================================================================================================================
+end subroutine journal
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+function upper(str)result(string)
+
+! ident_12="@(#) M_CLI2 upper(3f) Changes a string to uppercase"
+
+character(*),intent(in)::str
+character(:),allocatable::string
+integer::i
+string=str
+do i=1,len_trim(str)
+select case(str(i:i))
+case('a':'z')
+string(i:i)=char(iachar(str(i:i))-32)
+end select
+ end do
+end function upper
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+function lower(str)result(string)
+
+! ident_13="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range"
+
+character(*),intent(In)::str
+character(:),allocatable::string
+integer::i
+string=str
+do i=1,len_trim(str)
+select case(str(i:i))
+case('A':'Z')
+string(i:i)=char(iachar(str(i:i))+32)
+end select
+ end do
+end function lower
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+subroutine a2i(chars,valu,ierr)
+
+! ident_14="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string"
+
+character(len=*),intent(in)::chars! input string
+integer,intent(out)::valu! value read from input string
+integer,intent(out)::ierr! error flag (0 == no error)
+doubleprecision::valu8
+integer,parameter::ihuge=huge(0)
+valu8=0.0d0
+call a2d(chars,valu8,ierr,onerr=0.0d0)
+if(valu8<=huge(valu))then
+ if(valu8<=huge(valu))then
+valu=int(valu8)
+else
+ call journal('*a2i*','- value too large',valu8,'>',ihuge)
+valu=huge(valu)
+ierr=-1
+endif
+ endif
+end subroutine a2i
+!----------------------------------------------------------------------------------------------------------------------------------
+subroutine a2d(chars,valu,ierr,onerr)
+
+! ident_15="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string"
+
+! 1989,2016 John S. Urban.
+!
+! o works with any g-format input, including integer, real, and exponential.
+! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0.
+! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data.
+! IERR will still be non-zero in this case.
+!----------------------------------------------------------------------------------------------------------------------------------
+character(len=*),intent(in)::chars! input string
+character(len=:),allocatable::local_chars
+doubleprecision,intent(out)::valu! value read from input string
+integer,intent(out)::ierr! error flag (0 == no error)
+class(*),optional,intent(in)::onerr
+!----------------------------------------------------------------------------------------------------------------------------------
+character(len=*),parameter::fmt="('(bn,g',i5,'.0)')"! format used to build frmt
+character(len=15)::frmt! holds format built to read input string
+character(len=256)::msg! hold message from I/O errors
+integer::intg
+integer::pnd
+integer::basevalue,ivalu
+character(len=3),save::nan_string='NaN'
+!----------------------------------------------------------------------------------------------------------------------------------
+ierr=0! initialize error flag to zero
+local_chars=unquote(chars)
+msg=''
+if(len(local_chars)==0)local_chars=' '
+local_chars=replace_str(local_chars,',','')! remove any comma characters
+pnd=scan(local_chars,'#:')
+if(pnd/=0)then
+ write(frmt,fmt)pnd-1! build format of form '(BN,Gn.0)'
+read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue! try to read value from string
+if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then
+valu=real(ivalu,kind=kind(0.0d0))
+else
+valu=0.0d0
+ierr=-1
+endif
+ else
+ select case(local_chars(1:1))
+case('z','Z','h','H')! assume hexadecimal
+write(frmt,"('(Z',i0,')')")len(local_chars)
+read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
+valu=dble(intg)
+case('b','B')! assume binary (base 2)
+write(frmt,"('(B',i0,')')")len(local_chars)
+read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
+valu=dble(intg)
+case('o','O')! assume octal
+write(frmt,"('(O',i0,')')")len(local_chars)
+read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
+valu=dble(intg)
+case default
+write(frmt,fmt)len(local_chars)! build format of form '(BN,Gn.0)'
+read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu! try to read value from string
+end select
+ endif
+ if(ierr/=0)then! if an error occurred ierr will be non-zero.
+if(present(onerr))then
+ select type(onerr)
+type is(integer)
+valu=onerr
+type is(real)
+valu=onerr
+type is(doubleprecision)
+valu=onerr
+end select
+ else! set return value to NaN
+read(nan_string,'(f3.3)')valu
+endif
+ if(local_chars/='eod')then! print warning message except for special value "eod"
+call journal('*a2d* - cannot produce number from string ['//trim(chars)//']')
+if(msg/='')then
+ call journal('*a2d* - ['//trim(msg)//']')
+endif
+ endif
+ endif
+end subroutine a2d
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified
+!! delimiters
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine split(input_line,array,delimiters,order,nulls)
+!!
+!! character(len=*),intent(in) :: input_line
+!! character(len=:),allocatable,intent(out) :: array(:)
+!! character(len=*),optional,intent(in) :: delimiters
+!! character(len=*),optional,intent(in) :: order
+!! character(len=*),optional,intent(in) :: nulls
+!!##DESCRIPTION
+!! SPLIT(3f) parses a string using specified delimiter characters and
+!! store tokens into an allocatable array
+!!
+!!##OPTIONS
+!!
+!! INPUT_LINE Input string to tokenize
+!!
+!! ARRAY Output array of tokens
+!!
+!! DELIMITERS List of delimiter characters.
+!! The default delimiters are the "whitespace" characters
+!! (space, tab,new line, vertical tab, formfeed, carriage
+!! return, and null). You may specify an alternate set of
+!! delimiter characters.
+!!
+!! Multi-character delimiters are not supported (Each
+!! character in the DELIMITERS list is considered to be
+!! a delimiter).
+!!
+!! Quoting of delimiter characters is not supported.
+!!
+!! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array.
+!! By default ARRAY contains the tokens having parsed
+!! the INPUT_LINE from left to right. If ORDER='RIGHT'
+!! or ORDER='REVERSE' the parsing goes from right to left.
+!!
+!! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields.
+!! By default adjacent delimiters in the input string
+!! do not create an empty string in the output array. if
+!! NULLS='return' adjacent delimiters create an empty element
+!! in the output ARRAY. If NULLS='ignoreend' then only
+!! trailing delimiters at the right of the string are ignored.
+!!
+!!##EXAMPLES
+!!
+!! Sample program:
+!!
+!! program demo_split
+!! use M_CLI2, only: split
+!! character(len=*),parameter :: &
+!! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc '
+!! character(len=:),allocatable :: array(:) ! output array of tokens
+!! write(*,*)'INPUT LINE:['//LINE//']'
+!! write(*,'(80("="))')
+!! write(*,*)'typical call:'
+!! CALL split(line,array)
+!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
+!! write(*,*)'SIZE:',SIZE(array)
+!! write(*,'(80("-"))')
+!! write(*,*)'custom list of delimiters (colon and vertical line):'
+!! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore')
+!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
+!! write(*,*)'SIZE:',SIZE(array)
+!! write(*,'(80("-"))')
+!! write(*,*)&
+!! &'custom list of delimiters, reverse array order and count null fields:'
+!! CALL split(line,array,delimiters=':|',order='reverse',nulls='return')
+!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
+!! write(*,*)'SIZE:',SIZE(array)
+!! write(*,'(80("-"))')
+!! write(*,*)'INPUT LINE:['//LINE//']'
+!! write(*,*)&
+!! &'default delimiters and reverse array order and return null fields:'
+!! CALL split(line,array,delimiters='',order='reverse',nulls='return')
+!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
+!! write(*,*)'SIZE:',SIZE(array)
+!! end program demo_split!!
-!! Multi-character delimiters are not supported (Each
-!! character in the DELIMITERS list is considered to be
-!! a delimiter).
-!!
-!! Quoting of delimiter characters is not supported.
-!!
-!! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array.
-!! By default ARRAY contains the tokens having parsed
-!! the INPUT_LINE from left to right. If ORDER='RIGHT'
-!! or ORDER='REVERSE' the parsing goes from right to left.
-!!
-!! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields.
-!! By default adjacent delimiters in the input string
-!! do not create an empty string in the output array. if
-!! NULLS='return' adjacent delimiters create an empty element
-!! in the output ARRAY. If NULLS='ignoreend' then only
-!! trailing delimiters at the right of the string are ignored.
-!!
-!!##EXAMPLES
-!!
-!! Sample program:
-!!
-!! program demo_split
-!! use M_CLI2, only: split
-!! character(len=*),parameter :: &
-!! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc '
-!! character(len=:),allocatable :: array(:) ! output array of tokens
-!! write(*,*)'INPUT LINE:['//LINE//']'
-!! write(*,'(80("="))')
-!! write(*,*)'typical call:'
-!! CALL split(line,array)
-!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
-!! write(*,*)'SIZE:',SIZE(array)
-!! write(*,'(80("-"))')
-!! write(*,*)'custom list of delimiters (colon and vertical line):'
-!! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore')
-!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
-!! write(*,*)'SIZE:',SIZE(array)
-!! write(*,'(80("-"))')
-!! write(*,*)&
-!! &'custom list of delimiters, reverse array order and count null fields:'
-!! CALL split(line,array,delimiters=':|',order='reverse',nulls='return')
-!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
-!! write(*,*)'SIZE:',SIZE(array)
-!! write(*,'(80("-"))')
-!! write(*,*)'INPUT LINE:['//LINE//']'
-!! write(*,*)&
-!! &'default delimiters and reverse array order and return null fields:'
-!! CALL split(line,array,delimiters='',order='reverse',nulls='return')
-!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array))
-!! write(*,*)'SIZE:',SIZE(array)
-!! end program demo_split
-!!
-!! Output
-!!
-!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ]
-!! > ===========================================================================
-!! > typical call:
-!! > 1 ==> aBcdef
-!! > 2 ==> ghijklmnop
-!! > 3 ==> qrstuvwxyz
-!! > 4 ==> 1:|:2
-!! > 5 ==> 333|333
-!! > 6 ==> a
-!! > 7 ==> B
-!! > 8 ==> cc
-!! > SIZE: 8
-!! > --------------------------------------------------------------------------
-!! > custom list of delimiters (colon and vertical line):
-!! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1
-!! > 2 ==> 2 333
-!! > 3 ==> 333 a B cc
-!! > SIZE: 3
-!! > --------------------------------------------------------------------------
-!! > custom list of delimiters, reverse array order and return null fields:
-!! > 1 ==> 333 a B cc
-!! > 2 ==> 2 333
-!! > 3 ==>
-!! > 4 ==>
-!! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1
-!! > SIZE: 5
-!! > --------------------------------------------------------------------------
-!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ]
-!! > default delimiters and reverse array order and count null fields:
-!! > 1 ==>
-!! > 2 ==>
-!! > 3 ==>
-!! > 4 ==> cc
-!! > 5 ==> B
-!! > 6 ==> a
-!! > 7 ==> 333|333
-!! > 8 ==>
-!! > 9 ==>
-!! > 10 ==>
-!! > 11 ==>
-!! > 12 ==> 1:|:2
-!! > 13 ==>
-!! > 14 ==> qrstuvwxyz
-!! > 15 ==> ghijklmnop
-!! > 16 ==>
-!! > 17 ==>
-!! > 18 ==> aBcdef
-!! > 19 ==>
-!! > 20 ==>
-!! > SIZE: 20
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine split(input_line,array,delimiters,order,nulls)
-!-----------------------------------------------------------------------------------------------------------------------------------
-
-! ident_20="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array"
-
-! John S. Urban
-!-----------------------------------------------------------------------------------------------------------------------------------
-intrinsic index,min,present,len
-!-----------------------------------------------------------------------------------------------------------------------------------
-! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array.
-! o by default adjacent delimiters in the input string do not create an empty string in the output array
-! o no quoting of delimiters is supported
-character(len=*),intent(in)::input_line! input string to tokenize
-character(len=*),optional,intent(in)::delimiters! list of delimiter characters
-character(len=*),optional,intent(in)::order! order of output array sequential|[reverse|right]
-character(len=*),optional,intent(in)::nulls! return strings composed of delimiters or not ignore|return|ignoreend
-character(len=:),allocatable,intent(out)::array(:)! output array of tokens
-!-----------------------------------------------------------------------------------------------------------------------------------
-integer::n! max number of strings INPUT_LINE could split into if all delimiter
-integer,allocatable::ibegin(:)! positions in input string where tokens start
-integer,allocatable::iterm(:)! positions in input string where tokens end
-character(len=:),allocatable::dlim! string containing delimiter characters
-character(len=:),allocatable::ordr! string containing order keyword
-character(len=:),allocatable::nlls! string containing nulls keyword
-integer::ii,iiii! loop parameters used to control print order
-integer::icount! number of tokens found
-integer::iilen! length of input string with trailing spaces trimmed
-integer::i10,i20,i30! loop counters
-integer::icol! pointer into input string as it is being parsed
-integer::idlim! number of delimiter characters
-integer::ifound! where next delimiter character is found in remaining input string data
-integer::inotnull! count strings not composed of delimiters
-integer::ireturn! number of tokens returned
-integer::imax! length of longest token
+!! Output
+!!
+!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ]
+!! > ===========================================================================
+!! > typical call:
+!! > 1 ==> aBcdef
+!! > 2 ==> ghijklmnop
+!! > 3 ==> qrstuvwxyz
+!! > 4 ==> 1:|:2
+!! > 5 ==> 333|333
+!! > 6 ==> a
+!! > 7 ==> B
+!! > 8 ==> cc
+!! > SIZE: 8
+!! > --------------------------------------------------------------------------
+!! > custom list of delimiters (colon and vertical line):
+!! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1
+!! > 2 ==> 2 333
+!! > 3 ==> 333 a B cc
+!! > SIZE: 3
+!! > --------------------------------------------------------------------------
+!! > custom list of delimiters, reverse array order and return null fields:
+!! > 1 ==> 333 a B cc
+!! > 2 ==> 2 333
+!! > 3 ==>
+!! > 4 ==>
+!! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1
+!! > SIZE: 5
+!! > --------------------------------------------------------------------------
+!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ]
+!! > default delimiters and reverse array order and count null fields:
+!! > 1 ==>
+!! > 2 ==>
+!! > 3 ==>
+!! > 4 ==> cc
+!! > 5 ==> B
+!! > 6 ==> a
+!! > 7 ==> 333|333
+!! > 8 ==>
+!! > 9 ==>
+!! > 10 ==>
+!! > 11 ==>
+!! > 12 ==> 1:|:2
+!! > 13 ==>
+!! > 14 ==> qrstuvwxyz
+!! > 15 ==> ghijklmnop
+!! > 16 ==>
+!! > 17 ==>
+!! > 18 ==> aBcdef
+!! > 19 ==>
+!! > 20 ==>
+!! > SIZE: 20
+!!##AUTHOR
+!! John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine split(input_line,array,delimiters,order,nulls)
+!-----------------------------------------------------------------------------------------------------------------------------------
+
+! ident_16="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array"
+
+! John S. Urban
+!-----------------------------------------------------------------------------------------------------------------------------------
+intrinsic index,min,present,len
+!-----------------------------------------------------------------------------------------------------------------------------------
+! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array.
+! o by default adjacent delimiters in the input string do not create an empty string in the output array
+! o no quoting of delimiters is supported
+character(len=*),intent(in)::input_line! input string to tokenize
+character(len=*),optional,intent(in)::delimiters! list of delimiter characters
+character(len=*),optional,intent(in)::order! order of output array sequential|[reverse|right]
+character(len=*),optional,intent(in)::nulls! return strings composed of delimiters or not ignore|return|ignoreend
+character(len=:),allocatable,intent(out)::array(:)! output array of tokens
+!-----------------------------------------------------------------------------------------------------------------------------------
+integer::n! max number of strings INPUT_LINE could split into if all delimiter
+integer,allocatable::ibegin(:)! positions in input string where tokens start
+integer,allocatable::iterm(:)! positions in input string where tokens end
+character(len=:),allocatable::dlim! string containing delimiter characters
+character(len=:),allocatable::ordr! string containing order keyword
+character(len=:),allocatable::nlls! string containing nulls keyword
+integer::ii,iiii! loop parameters used to control print order
+integer::icount! number of tokens found
+integer::iilen! length of input string with trailing spaces trimmed
+integer::i10,i20,i30! loop counters
+integer::icol! pointer into input string as it is being parsed
+integer::idlim! number of delimiter characters
+integer::ifound! where next delimiter character is found in remaining input string data
+integer::inotnull! count strings not composed of delimiters
+integer::ireturn! number of tokens returned
+integer::imax! length of longest token
+!-----------------------------------------------------------------------------------------------------------------------------------
+! decide on value for optional DELIMITERS parameter
+if(present(delimiters))then! optional delimiter list was present
+if(delimiters/='')then! if DELIMITERS was specified and not null use it
+dlim=delimiters
+else! DELIMITERS was specified on call as empty string
+dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:'! use default delimiter when not specified
+endif
+ else! no delimiter value was specified
+dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:'! use default delimiter when not specified
+endif
+idlim=len(dlim)! dlim a lot of blanks on some machines if dlim is a big string
+!-----------------------------------------------------------------------------------------------------------------------------------
+if(present(order))then;ordr=lower(adjustl(order));else;ordr='sequential';endif! decide on value for optional ORDER parameter
+if(present(nulls))then;nlls=lower(adjustl(nulls));else;nlls='ignore';endif! optional parameter
+!-----------------------------------------------------------------------------------------------------------------------------------
+n=len(input_line)+1! max number of strings INPUT_LINE could split into if all delimiter
+if(allocated(ibegin))deallocate(ibegin)!x! intel compiler says allocated already ???
+allocate(ibegin(n))! allocate enough space to hold starting location of tokens if string all tokens
+if(allocated(iterm))deallocate(iterm)!x! intel compiler says allocated already ???
+allocate(iterm(n))! allocate enough space to hold ending location of tokens if string all tokens
+ibegin(:)=1
+iterm(:)=1
+!-----------------------------------------------------------------------------------------------------------------------------------
+iilen=len(input_line)! IILEN is the column position of the last non-blank character
+icount=0! how many tokens found
+inotnull=0! how many tokens found not composed of delimiters
+imax=0! length of longest token found
+if(iilen>0)then! there is at least one non-delimiter in INPUT_LINE if get here
+icol=1! initialize pointer into input line
+INFINITE:do i30=1,iilen,1! store into each array element
+ibegin(i30)=icol! assume start new token on the character
+if(index(dlim(1:idlim),input_line(icol:icol))==0)then! if current character is not a delimiter
+iterm(i30)=iilen! initially assume no more tokens
+do i10=1,idlim! search for next delimiter
+ifound=index(input_line(ibegin(i30):iilen),dlim(i10:i10))
+IF(ifound>0)then
+iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2)
+endif
+ enddo
+icol=iterm(i30)+2! next place to look as found end of this token
+inotnull=inotnull+1! increment count of number of tokens not composed of delimiters
+else! character is a delimiter for a null string
+iterm(i30)=icol-1! record assumed end of string. Will be less than beginning
+icol=icol+1! advance pointer into input string
+endif
+imax=max(imax,iterm(i30)-ibegin(i30)+1)
+icount=i30! increment count of number of tokens found
+if(icol>iilen)then! no text left
+exit INFINITE
+endif
+ enddo INFINITE
+endif!-----------------------------------------------------------------------------------------------------------------------------------
-! decide on value for optional DELIMITERS parameter
-if(present(delimiters))then! optional delimiter list was present
-if(delimiters/='')then! if DELIMITERS was specified and not null use it
-dlim=delimiters
-else! DELIMITERS was specified on call as empty string
-dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:'! use default delimiter when not specified
-endif
- else! no delimiter value was specified
-dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:'! use default delimiter when not specified
-endif
-idlim=len(dlim)! dlim a lot of blanks on some machines if dlim is a big string
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(present(order))then;ordr=lower(adjustl(order));else;ordr='sequential';endif! decide on value for optional ORDER parameter
-if(present(nulls))then;nlls=lower(adjustl(nulls));else;nlls='ignore';endif! optional parameter
+select case(trim(adjustl(nlls)))
+case('ignore','','ignoreend')
+ireturn=inotnull
+case default
+ireturn=icount
+end select
+ if(allocated(array))deallocate(array)
+allocate(character(len=imax)::array(ireturn))! allocate the array to return
+!allocate(array(ireturn)) ! allocate the array to turn
+!-----------------------------------------------------------------------------------------------------------------------------------
+select case(trim(adjustl(ordr)))! decide which order to store tokens
+case('reverse','right');ii=ireturn;iiii=-1! last to first
+case default;ii=1;iiii=1! first to last
+end select!-----------------------------------------------------------------------------------------------------------------------------------
-n=len(input_line)+1! max number of strings INPUT_LINE could split into if all delimiter
-if(allocated(ibegin))deallocate(ibegin)!x! intel compiler says allocated already ???
-allocate(ibegin(n))! allocate enough space to hold starting location of tokens if string all tokens
-if(allocated(iterm))deallocate(iterm)!x! intel compiler says allocated already ???
-allocate(iterm(n))! allocate enough space to hold ending location of tokens if string all tokens
-ibegin(:)=1
-iterm(:)=1
-!-----------------------------------------------------------------------------------------------------------------------------------
-iilen=len(input_line)! IILEN is the column position of the last non-blank character
-icount=0! how many tokens found
-inotnull=0! how many tokens found not composed of delimiters
-imax=0! length of longest token found
-if(iilen>0)then! there is at least one non-delimiter in INPUT_LINE if get here
-icol=1! initialize pointer into input line
-INFINITE:do i30=1,iilen,1! store into each array element
-ibegin(i30)=icol! assume start new token on the character
-if(index(dlim(1:idlim),input_line(icol:icol))==0)then! if current character is not a delimiter
-iterm(i30)=iilen! initially assume no more tokens
-do i10=1,idlim! search for next delimiter
-ifound=index(input_line(ibegin(i30):iilen),dlim(i10:i10))
-IF(ifound>0)then
-iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2)
-endif
- enddo
-icol=iterm(i30)+2! next place to look as found end of this token
-inotnull=inotnull+1! increment count of number of tokens not composed of delimiters
-else! character is a delimiter for a null string
-iterm(i30)=icol-1! record assumed end of string. Will be less than beginning
-icol=icol+1! advance pointer into input string
-endif
-imax=max(imax,iterm(i30)-ibegin(i30)+1)
-icount=i30! increment count of number of tokens found
-if(icol>iilen)then! no text left
-exit INFINITE
-endif
- enddo INFINITE
-endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-select case(trim(adjustl(nlls)))
-case('ignore','','ignoreend')
-ireturn=inotnull
-case default
-ireturn=icount
-end select
- if(allocated(array))deallocate(array)
-allocate(character(len=imax)::array(ireturn))! allocate the array to return
-!allocate(array(ireturn)) ! allocate the array to turn
-!-----------------------------------------------------------------------------------------------------------------------------------
-select case(trim(adjustl(ordr)))! decide which order to store tokens
-case('reverse','right');ii=ireturn;iiii=-1! last to first
-case default;ii=1;iiii=1! first to last
-end select
-!-----------------------------------------------------------------------------------------------------------------------------------
-do i20=1,icount! fill the array with the tokens that were found
-if(iterm(i20)<ibegin(i20))then
- select case(trim(adjustl(nlls)))
-case('ignore','','ignoreend')
-case default
-array(ii)=' '
-ii=ii+iiii
-end select
- else
- array(ii)=input_line(ibegin(i20):iterm(i20))
-ii=ii+iiii
-endif
- enddo
-!-----------------------------------------------------------------------------------------------------------------------------------
-end subroutine split
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one
-!! substring for another in string
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function replace_str(targetline[,old,new|cmd],range,ierr) result (newline)
+do i20=1,icount! fill the array with the tokens that were found
+if(iterm(i20)<ibegin(i20))then
+ select case(trim(adjustl(nlls)))
+case('ignore','','ignoreend')
+case default
+array(ii)=' '
+ii=ii+iiii
+end select
+ else
+ array(ii)=input_line(ibegin(i20):iterm(i20))
+ii=ii+iiii
+endif
+ enddo
+!-----------------------------------------------------------------------------------------------------------------------------------
+end subroutine split
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one
+!! substring for another in string
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! function replace_str(targetline,old,new,range,ierr) result (newline)
+!!
+!! character(len=*) :: targetline
+!! character(len=*),intent(in) :: old
+!! character(len=*),intent(in) :: new
+!! integer,intent(in),optional :: range(2)
+!! integer,intent(out),optional :: ierr
+!! logical,intent(in),optional :: clip
+!! character(len=:),allocatable :: newline
+!!##DESCRIPTION
+!! Globally replace one substring for another in string.
+!! Either CMD or OLD and NEW must be specified.
+!!
+!!##OPTIONS
+!! targetline input line to be changed
+!! old old substring to replace
+!! new new substring
+!! range if present, only change range(1) to range(2) of
+!! occurrences of old string
+!! ierr error code. If ier = -1 bad directive, >= 0 then
+!! count of changes made
+!! clip whether to return trailing spaces or not. Defaults to .false.
+!!##RETURNS
+!! newline allocatable string returned
+!!
+!!##EXAMPLES
+!!
+!! Sample Program:
+!!
+!! program demo_replace_str
+!! use M_CLI2, only : replace_str
+!! implicit none
+!! character(len=:),allocatable :: targetline
+!!
+!! targetline='this is the input string'
+!!
+!! call testit('th','TH','THis is THe input string')
+!!
+!! ! a null old substring means "at beginning of line"
+!! call testit('','BEFORE:', 'BEFORE:THis is THe input string')
+!!
+!! ! a null new string deletes occurrences of the old substring
+!! call testit('i','', 'BEFORE:THs s THe nput strng')
+!!
+!! targetline=replace_str('a b ab baaa aaaa','a','A')
+!! write(*,*)'replace a with A ['//targetline//']'
+!!
+!! write(*,*)'Examples of the use of RANGE='
+!!
+!! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5])
+!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']'
+!!
+!! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5])
+!! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']'!!
-!! character(len=*) :: targetline
-!! character(len=*),intent(in),optional :: old
-!! character(len=*),intent(in),optional :: new
-!! character(len=*),intent(in),optional :: cmd
-!! integer,intent(in),optional :: range(2)
-!! integer,intent(out),optional :: ierr
-!! logical,intent(in),optional :: clip
-!! character(len=:),allocatable :: newline
-!!##DESCRIPTION
-!! Globally replace one substring for another in string.
-!! Either CMD or OLD and NEW must be specified.
-!!
-!!##OPTIONS
-!! targetline input line to be changed
-!! old old substring to replace
-!! new new substring
-!! cmd alternate way to specify old and new string, in
-!! the form c/old/new/; where "/" can be any character
-!! not in "old" or "new"
-!! range if present, only change range(1) to range(2) of
-!! occurrences of old string
-!! ierr error code. If ier = -1 bad directive, >= 0 then
-!! count of changes made
-!! clip whether to return trailing spaces or not. Defaults to .false.
-!!##RETURNS
-!! newline allocatable string returned
-!!
-!!##EXAMPLES
-!!
-!! Sample Program:
-!!
-!! program demo_replace_str
-!! use M_CLI2, only : replace_str
-!! implicit none
-!! character(len=:),allocatable :: targetline
-!!
-!! targetline='this is the input string'
-!!
-!! call testit('th','TH','THis is THe input string')
-!!
-!! ! a null old substring means "at beginning of line"
-!! call testit('','BEFORE:', 'BEFORE:THis is THe input string')
-!!
-!! ! a null new string deletes occurrences of the old substring
-!! call testit('i','', 'BEFORE:THs s THe nput strng')
-!!
-!! write(*,*)'Examples of the use of RANGE='
-!!
-!! targetline=replace_str('a b ab baaa aaaa','a','A')
-!! write(*,*)'replace a with A ['//targetline//']'
-!!
-!! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5])
-!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']'
-!!
-!! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5])
-!! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']'
-!!
-!! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',&
-!! & 'aa','CCCC',range=[3,5])
-!! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']'
-!!
-!! contains
-!! subroutine testit(old,new,expected)
-!! character(len=*),intent(in) :: old,new,expected
-!! write(*,*)repeat('=',79)
-!! write(*,*)':STARTED ['//targetline//']'
-!! write(*,*)':OLD['//old//']', ' NEW['//new//']'
-!! targetline=replace_str(targetline,old,new)
-!! write(*,*)':GOT ['//targetline//']'
-!! write(*,*)':EXPECTED['//expected//']'
-!! write(*,*)':TEST [',targetline == expected,']'
-!! end subroutine testit
-!!
-!! end program demo_replace_str
-!!
-!! Expected output
-!!
-!! ===============================================================================
-!! STARTED [this is the input string]
-!! OLD[th] NEW[TH]
-!! GOT [THis is THe input string]
-!! EXPECTED[THis is THe input string]
-!! TEST [ T ]
-!! ===============================================================================
-!! STARTED [THis is THe input string]
-!! OLD[] NEW[BEFORE:]
-!! GOT [BEFORE:THis is THe input string]
-!! EXPECTED[BEFORE:THis is THe input string]
-!! TEST [ T ]
-!! ===============================================================================
-!! STARTED [BEFORE:THis is THe input string]
-!! OLD[i] NEW[]
-!! GOT [BEFORE:THs s THe nput strng]
-!! EXPECTED[BEFORE:THs s THe nput strng]
-!! TEST [ T ]
-!! Examples of the use of RANGE=
-!! replace a with A [A b Ab bAAA AAAA]
-!! replace a with A instances 3 to 5 [a b ab bAAA aaaa]
-!! replace a with null instances 3 to 5 [a b ab b aaaa]
-!! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC
-!! a a a aa aaaaaa]
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine crack_cmd(cmd,old,new,ierr)
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=*),intent(in)::cmd
-character(len=:),allocatable,intent(out)::old,new! scratch string buffers
-integer::ierr
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=1)::delimiters
-integer::itoken
-integer,parameter::id=2! expected location of delimiter
-logical::ifok
-integer::lmax! length of target string
-integer::start_token,end_token
-!-----------------------------------------------------------------------------------------------------------------------------------
-ierr=0
-old=''
-new=''
-lmax=len_trim(cmd)! significant length of change directive
-
-if(lmax>=4)then! strtok ignores blank tokens so look for special case where first token is really null
-delimiters=cmd(id:id)! find delimiter in expected location
-itoken=0! initialize strtok(3f) procedure
-
-if(strtok(cmd(id:),itoken,start_token,end_token,delimiters))then! find OLD string
-old=cmd(start_token+id-1:end_token+id-1)
-else
-old=''
-endif
-
- if(cmd(id:id)==cmd(id+1:id+1))then
-new=old
-old=''
-else! normal case
-ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters)! find NEW string
-if(end_token==(len(cmd)-id+1))end_token=len_trim(cmd(id:))! if missing ending delimiter
-new=cmd(start_token+id-1:min(end_token+id-1,lmax))
-endif
- else! command was two or less characters
-ierr=-1
-call journal('sc','*crack_cmd* incorrect change directive -too short')
-endif
-
-end subroutine crack_cmd
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function replace_str(targetline,old,new,ierr,cmd,range)result(newline)
-
-! ident_21="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string"
-
-!-----------------------------------------------------------------------------------------------------------------------------------
-! parameters
-character(len=*),intent(in)::targetline! input line to be changed
-character(len=*),intent(in),optional::old! old substring to replace
-character(len=*),intent(in),optional::new! new substring
-integer,intent(out),optional::ierr! error code. If ierr = -1 bad directive, >=0 then ierr changes made
-character(len=*),intent(in),optional::cmd! contains the instructions changing the string
-integer,intent(in),optional::range(2)! start and end of which changes to make
-!-----------------------------------------------------------------------------------------------------------------------------------
-! returns
-character(len=:),allocatable::newline! output string buffer
-!-----------------------------------------------------------------------------------------------------------------------------------
-! local
-character(len=:),allocatable::new_local,old_local
-integer::icount,ichange,ier2
-integer::original_input_length
-integer::len_old,len_new
-integer::ladd
-integer::left_margin,right_margin
-integer::ind
-integer::ic
-integer::iichar
-integer::range_local(2)
-!-----------------------------------------------------------------------------------------------------------------------------------
-! get old_local and new_local from cmd or old and new
-if(present(cmd))then
- call crack_cmd(cmd,old_local,new_local,ier2)
-if(ier2/=0)then
-newline=targetline! if no changes are made return original string on error
-if(present(ierr))ierr=ier2
-return
- endif
-elseif(present(old).and.present(new))then
-old_local=old
-new_local=new
-else
-newline=targetline! if no changes are made return original string on error
-call journal('sc','*replace_str* must specify OLD and NEW or CMD')
-return
- endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-icount=0! initialize error flag/change count
-ichange=0! initialize error flag/change count
-original_input_length=len_trim(targetline)! get non-blank length of input line
-len_old=len(old_local)! length of old substring to be replaced
-len_new=len(new_local)! length of new substring to replace old substring
-left_margin=1! left_margin is left margin of window to change
-right_margin=len(targetline)! right_margin is right margin of window to change
-newline=''! begin with a blank line as output string
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(present(range))then
-range_local=range
-else
-range_local=[1,original_input_length]
-endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(len_old==0)then! c//new/ means insert new at beginning of line (or left margin)
-iichar=len_new+original_input_length
-if(len_new>0)then
-newline=new_local(:len_new)//targetline(left_margin:original_input_length)
-else
-newline=targetline(left_margin:original_input_length)
-endif
-ichange=1! made one change. actually, c/// should maybe return 0
-if(present(ierr))ierr=ichange
-return
- endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-iichar=left_margin! place to put characters into output string
-ic=left_margin! place looking at in input string
-loop:do
-ind=index(targetline(ic:),old_local(:len_old))+ic-1! try finding start of OLD in remaining part of input in change window
-if(ind==ic-1.or.ind>right_margin)then! did not find old string or found old string past edit window
-exit loop! no more changes left to make
-endif
-icount=icount+1! found an old string to change, so increment count of change candidates
-if(ind>ic)then! if found old string past at current position in input string copy unchanged
-ladd=ind-ic! find length of character range to copy as-is from input to output
-newline=newline(:iichar-1)//targetline(ic:ind-1)
-iichar=iichar+ladd
-endif
- if(icount>=range_local(1).and.icount<=range_local(2))then! check if this is an instance to change or keep
-ichange=ichange+1
-if(len_new/=0)then! put in new string
-newline=newline(:iichar-1)//new_local(:len_new)
-iichar=iichar+len_new
-endif
- else
- if(len_old/=0)then! put in copy of old string
-newline=newline(:iichar-1)//old_local(:len_old)
-iichar=iichar+len_old
-endif
- endif
-ic=ind+len_old
-enddo loop
-!-----------------------------------------------------------------------------------------------------------------------------------
-select case(ichange)
-case(0)! there were no changes made to the window
-newline=targetline! if no changes made output should be input
-case default
-if(ic<=len(targetline))then! if there is more after last change on original line add it
-newline=newline(:iichar-1)//targetline(ic:max(ic,original_input_length))
-endif
- end select
- if(present(ierr))ierr=ichange
-!-----------------------------------------------------------------------------------------------------------------------------------
-end function replace_str
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with
-!! list-directed input
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! function quote(str,mode,clip) result (quoted_str)
-!!
-!! character(len=*),intent(in) :: str
-!! character(len=*),optional,intent(in) :: mode
-!! logical,optional,intent(in) :: clip
-!! character(len=:),allocatable :: quoted_str
-!!##DESCRIPTION
-!! Add quotes to a CHARACTER variable as if it was written using
-!! list-directed input. This is particularly useful for processing
-!! strings to add to CSV files.
-!!
-!!##OPTIONS
-!! str input string to add quotes to, using the rules of
-!! list-directed input (single quotes are replaced by two
-!! adjacent quotes)
-!! mode alternate quoting methods are supported:
-!!
-!! DOUBLE default. replace quote with double quotes
-!! ESCAPE replace quotes with backslash-quote instead
-!! of double quotes
-!!
-!! clip default is to trim leading and trailing spaces from the
-!! string. If CLIP
-!! is .FALSE. spaces are not trimmed
+!! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',&
+!! & 'aa','CCCC',range=[3,5])
+!! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']'
+!!
+!! contains
+!! subroutine testit(old,new,expected)
+!! character(len=*),intent(in) :: old,new,expected
+!! write(*,*)repeat('=',79)
+!! write(*,*)':STARTED ['//targetline//']'
+!! write(*,*)':OLD['//old//']', ' NEW['//new//']'
+!! targetline=replace_str(targetline,old,new)
+!! write(*,*)':GOT ['//targetline//']'
+!! write(*,*)':EXPECTED['//expected//']'
+!! write(*,*)':TEST [',targetline == expected,']'
+!! end subroutine testit
+!!
+!! end program demo_replace_str
+!!
+!! Expected output
+!!
+!! ===============================================================================
+!! STARTED [this is the input string]
+!! OLD[th] NEW[TH]
+!! GOT [THis is THe input string]
+!! EXPECTED[THis is THe input string]
+!! TEST [ T ]
+!! ===============================================================================
+!! STARTED [THis is THe input string]
+!! OLD[] NEW[BEFORE:]
+!! GOT [BEFORE:THis is THe input string]
+!! EXPECTED[BEFORE:THis is THe input string]
+!! TEST [ T ]
+!! ===============================================================================
+!! STARTED [BEFORE:THis is THe input string]
+!! OLD[i] NEW[]
+!! GOT [BEFORE:THs s THe nput strng]
+!! EXPECTED[BEFORE:THs s THe nput strng]
+!! TEST [ T ]
+!! replace a with A [A b Ab bAAA AAAA]
+!! Examples of the use of RANGE=
+!! replace a with A instances 3 to 5 [a b ab bAAA aaaa]
+!! replace a with null instances 3 to 5 [a b ab b aaaa]
+!! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC
+!! a a a aa aaaaaa]
+!!
+!!##AUTHOR
+!! John S. Urban
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+function replace_str(targetline,old,new,ierr,range)result(newline)
+
+! ident_17="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string"
+
+!-----------------------------------------------------------------------------------------------------------------------------------
+! parameters
+character(len=*),intent(in)::targetline! input line to be changed
+character(len=*),intent(in)::old! old substring to replace
+character(len=*),intent(in)::new! new substring
+integer,intent(out),optional::ierr! error code. If ierr = -1 bad directive, >=0 then ierr changes made
+integer,intent(in),optional::range(2)! start and end of which changes to make
+!-----------------------------------------------------------------------------------------------------------------------------------
+! returns
+character(len=:),allocatable::newline! output string buffer
+!-----------------------------------------------------------------------------------------------------------------------------------
+! local
+integer::icount,ichange
+integer::original_input_length
+integer::len_old,len_new
+integer::ladd
+integer::left_margin,right_margin
+integer::ind
+integer::ic
+integer::iichar
+integer::range_local(2)
+!-----------------------------------------------------------------------------------------------------------------------------------
+icount=0! initialize error flag/change count
+ichange=0! initialize error flag/change count
+original_input_length=len_trim(targetline)! get non-blank length of input line
+len_old=len(old)! length of old substring to be replaced
+len_new=len(new)! length of new substring to replace old substring
+left_margin=1! left_margin is left margin of window to change
+right_margin=len(targetline)! right_margin is right margin of window to change
+newline=''! begin with a blank line as output string
+!-----------------------------------------------------------------------------------------------------------------------------------
+if(present(range))then
+range_local=range
+else
+range_local=[1,original_input_length]
+endif
+!-----------------------------------------------------------------------------------------------------------------------------------
+if(len_old==0)then! c//new/ means insert new at beginning of line (or left margin)
+iichar=len_new+original_input_length
+if(len_new>0)then
+newline=new(:len_new)//targetline(left_margin:original_input_length)
+else
+newline=targetline(left_margin:original_input_length)
+endif
+ichange=1! made one change. actually, c/// should maybe return 0
+if(present(ierr))ierr=ichange
+return
+ endif
+!-----------------------------------------------------------------------------------------------------------------------------------
+iichar=left_margin! place to put characters into output string
+ic=left_margin! place looking at in input string
+loop:do
+ind=index(targetline(ic:),old(:len_old))+ic-1! try finding start of OLD in remaining part of input in change window
+if(ind==ic-1.or.ind>right_margin)then! did not find old string or found old string past edit window
+exit loop! no more changes left to make
+endif
+icount=icount+1! found an old string to change, so increment count of change candidates
+if(ind>ic)then! if found old string past at current position in input string copy unchanged
+ladd=ind-ic! find length of character range to copy as-is from input to output
+newline=newline(:iichar-1)//targetline(ic:ind-1)
+iichar=iichar+ladd
+endif
+ if(icount>=range_local(1).and.icount<=range_local(2))then! check if this is an instance to change or keep
+ichange=ichange+1
+if(len_new/=0)then! put in new string
+newline=newline(:iichar-1)//new(:len_new)
+iichar=iichar+len_new
+endif
+ else
+ if(len_old/=0)then! put in copy of old string
+newline=newline(:iichar-1)//old(:len_old)
+iichar=iichar+len_old
+endif
+ endif
+ic=ind+len_old
+enddo loop
+!-----------------------------------------------------------------------------------------------------------------------------------
+select case(ichange)
+case(0)! there were no changes made to the window
+newline=targetline! if no changes made output should be input
+case default
+if(ic<=len(targetline))then! if there is more after last change on original line add it
+newline=newline(:iichar-1)//targetline(ic:max(ic,original_input_length))
+endif
+ end select
+ if(present(ierr))ierr=ichange
+!-----------------------------------------------------------------------------------------------------------------------------------
+end function replace_str
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with
+!! list-directed input
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! function quote(str,mode,clip) result (quoted_str)
+!!
+!! character(len=*),intent(in) :: str
+!! character(len=*),optional,intent(in) :: mode
+!! logical,optional,intent(in) :: clip
+!! character(len=:),allocatable :: quoted_str
+!!##DESCRIPTION
+!! Add quotes to a CHARACTER variable as if it was written using
+!! list-directed input. This is particularly useful for processing
+!! strings to add to CSV files.
+!!
+!!##OPTIONS
+!! str input string to add quotes to, using the rules of
+!! list-directed input (single quotes are replaced by two
+!! adjacent quotes)
+!! mode alternate quoting methods are supported:
+!!
+!! DOUBLE default. replace quote with double quotes
+!! ESCAPE replace quotes with backslash-quote instead
+!! of double quotes
+!!
+!! clip default is to trim leading and trailing spaces from the
+!! string. If CLIP
+!! is .FALSE. spaces are not trimmed
+!!
+!!##RESULT
+!! quoted_str The output string, which is based on adding quotes to STR.
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_quote
+!! use M_CLI2, only : quote
+!! implicit none
+!! character(len=:),allocatable :: str
+!! character(len=1024) :: msg
+!! integer :: ios
+!! character(len=80) :: inline
+!! do
+!! write(*,'(a)',advance='no')'Enter test string:'
+!! read(*,'(a)',iostat=ios,iomsg=msg)inline
+!! if(ios /= 0)then
+!! write(*,*)trim(inline)
+!! exit
+!! endif
+!!
+!! ! the original string
+!! write(*,'(a)')'ORIGINAL ['//trim(inline)//']'
+!!
+!! ! the string processed by quote(3f)
+!! str=quote(inline)
+!! write(*,'(a)')'QUOTED ['//str//']'
+!!
+!! ! write the string list-directed to compare the results
+!! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:'
+!! write(*,*,iostat=ios,iomsg=msg,delim='none') inline
+!! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline
+!! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline
+!! enddo
+!! end program demo_quote
+!!
+!!##AUTHOR
+!! John S. Urban
+!!##LICENSE
+!! Public Domain
+function quote(str,mode,clip)result(quoted_str)
+character(len=*),intent(in)::str! the string to be quoted
+character(len=*),optional,intent(in)::mode
+logical,optional,intent(in)::clip
+logical::clip_local
+character(len=:),allocatable::quoted_str
+
+character(len=1),parameter::double_quote='"'
+character(len=20)::local_mode
+
+if(present(mode))then
+local_mode=mode
+else
+local_mode='DOUBLE'
+endif
+
+ if(present(clip))then
+clip_local=clip
+else
+clip_local=.false.
+endif
+
+ if(clip_local)then
+quoted_str=adjustl(str)
+else
+quoted_str=str
+endif
+
+ select case(lower(local_mode))
+case('double')
+quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote
+case('escape')
+quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote
+case default
+call journal('*quote* ERROR: unknown quote mode ',local_mode)
+quoted_str=str
+end select
+
+end function quote
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read
+!! with list-directed input
+!! (LICENSE:PD)
+!!##SYNOPSIS
+!!
+!! pure function unquote(quoted_str,esc) result (unquoted_str)
+!!
+!! character(len=*),intent(in) :: quoted_str
+!! character(len=1),optional,intent(in) :: esc
+!! character(len=:),allocatable :: unquoted_str
+!!##DESCRIPTION
+!! Remove quotes from a CHARACTER variable as if it was read using
+!! list-directed input. This is particularly useful for processing
+!! tokens read from input such as CSV files.
+!!
+!! Fortran can now read using list-directed input from an internal file,
+!! which should handle quoted strings, but list-directed input does not
+!! support escape characters, which UNQUOTE(3f) does.
+!!##OPTIONS
+!! quoted_str input string to remove quotes from, using the rules of
+!! list-directed input (two adjacent quotes inside a quoted
+!! region are replaced by a single quote, a single quote or
+!! double quote is selected as the delimiter based on which
+!! is encountered first going from left to right, ...)
+!! esc optional character used to protect the next quote
+!! character from being processed as a quote, but simply as
+!! a plain character.
+!!##RESULT
+!! unquoted_str The output string, which is based on removing quotes
+!! from quoted_str.
+!!##EXAMPLE
+!!
+!! Sample program:!!
-!!##RESULT
-!! quoted_str The output string, which is based on adding quotes to STR.
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_quote
-!! use M_CLI2, only : quote
-!! implicit none
-!! character(len=:),allocatable :: str
-!! character(len=1024) :: msg
-!! integer :: ios
-!! character(len=80) :: inline
-!! do
-!! write(*,'(a)',advance='no')'Enter test string:'
-!! read(*,'(a)',iostat=ios,iomsg=msg)inline
-!! if(ios /= 0)then
-!! write(*,*)trim(inline)
-!! exit
-!! endif
-!!
-!! ! the original string
-!! write(*,'(a)')'ORIGINAL ['//trim(inline)//']'
+!! program demo_unquote
+!! use M_CLI2, only : unquote
+!! implicit none
+!! character(len=128) :: quoted_str
+!! character(len=:),allocatable :: unquoted_str
+!! character(len=1),parameter :: esc='\'
+!! character(len=1024) :: msg
+!! integer :: ios
+!! character(len=1024) :: dummy
+!! do
+!! write(*,'(a)',advance='no')'Enter test string:'
+!! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str
+!! if(ios /= 0)then
+!! write(*,*)trim(msg)
+!! exit
+!! endif
+!!
+!! ! the original string
+!! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']'
+!!
+!! ! the string processed by unquote(3f)
+!! unquoted_str=unquote(trim(quoted_str),esc)
+!! write(*,'(a)')'UNQUOTED ['//unquoted_str//']'!!
-!! ! the string processed by quote(3f)
-!! str=quote(inline)
-!! write(*,'(a)')'QUOTED ['//str//']'
-!!
-!! ! write the string list-directed to compare the results
-!! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:'
-!! write(*,*,iostat=ios,iomsg=msg,delim='none') inline
-!! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline
-!! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline
-!! enddo
-!! end program demo_quote
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function quote(str,mode,clip)result(quoted_str)
-character(len=*),intent(in)::str! the string to be quoted
-character(len=*),optional,intent(in)::mode
-logical,optional,intent(in)::clip
-logical::clip_local
-character(len=:),allocatable::quoted_str
-
-character(len=1),parameter::double_quote='"'
-character(len=20)::local_mode
-!-----------------------------------------------------------------------------------------------------------------------------------
-local_mode=merge_str(mode,'DOUBLE',present(mode))
-if(present(clip))then
-clip_local=clip
-else
-clip_local=.false.
-endif
- if(clip_local)then
-quoted_str=adjustl(str)
-else
-quoted_str=str
-endif
- select case(lower(local_mode))
-case('double')
-quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote
-case('escape')
-quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote
-case default
-call journal('sc','*quote* ERROR: unknown quote mode ',local_mode)
-quoted_str=str
-end select
-!-----------------------------------------------------------------------------------------------------------------------------------
-end function quote
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read
-!! with list-directed input
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! pure function unquote(quoted_str,esc) result (unquoted_str)
-!!
-!! character(len=*),intent(in) :: quoted_str
-!! character(len=1),optional,intent(in) :: esc
-!! character(len=:),allocatable :: unquoted_str
-!!##DESCRIPTION
-!! Remove quotes from a CHARACTER variable as if it was read using
-!! list-directed input. This is particularly useful for processing
-!! tokens read from input such as CSV files.
-!!
-!! Fortran can now read using list-directed input from an internal file,
-!! which should handle quoted strings, but list-directed input does not
-!! support escape characters, which UNQUOTE(3f) does.
-!!##OPTIONS
-!! quoted_str input string to remove quotes from, using the rules of
-!! list-directed input (two adjacent quotes inside a quoted
-!! region are replaced by a single quote, a single quote or
-!! double quote is selected as the delimiter based on which
-!! is encountered first going from left to right, ...)
-!! esc optional character used to protect the next quote
-!! character from being processed as a quote, but simply as
-!! a plain character.
-!!##RESULT
-!! unquoted_str The output string, which is based on removing quotes
-!! from quoted_str.
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_unquote
-!! use M_CLI2, only : unquote
-!! implicit none
-!! character(len=128) :: quoted_str
-!! character(len=:),allocatable :: unquoted_str
-!! character(len=1),parameter :: esc='\'
-!! character(len=1024) :: msg
-!! integer :: ios
-!! character(len=1024) :: dummy
-!! do
-!! write(*,'(a)',advance='no')'Enter test string:'
-!! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str
-!! if(ios /= 0)then
-!! write(*,*)trim(msg)
-!! exit
-!! endif
+!! ! read the string list-directed to compare the results
+!! read(quoted_str,*,iostat=ios,iomsg=msg)dummy
+!! if(ios /= 0)then
+!! write(*,*)trim(msg)
+!! else
+!! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']'
+!! endif
+!! enddo
+!! end program demo_unquote
+!!
+!!##AUTHOR
+!! John S. Urban
+!!##LICENSE
+!! Public Domain
+pure function unquote(quoted_str,esc)result(unquoted_str)
+character(len=*),intent(in)::quoted_str! the string to be unquoted
+character(len=1),optional,intent(in)::esc! escape character
+character(len=:),allocatable::unquoted_str
+integer::inlen
+character(len=1),parameter::single_quote="'"
+character(len=1),parameter::double_quote='"'
+integer::quote! whichever quote is to be used
+integer::before
+integer::current
+integer::iesc
+integer::iput
+integer::i
+logical::inside
+!-----------------------------------------------------------------------------------------------------------------------------------
+if(present(esc))then! select escape character as specified character or special value meaning not set
+iesc=ichar(esc)! allow for an escape character
+else
+iesc=-1! set to value that matches no character
+endif
+!-----------------------------------------------------------------------------------------------------------------------------------
+inlen=len(quoted_str)! find length of input string
+if(allocated(unquoted_str))deallocate(unquoted_str)
+allocate(character(len=inlen)::unquoted_str)! initially make output string length of input string
+!-----------------------------------------------------------------------------------------------------------------------------------
+if(inlen>=1)then! double_quote is the default quote unless the first character is single_quote
+if(quoted_str(1:1)==single_quote)then
+quote=ichar(single_quote)
+else
+quote=ichar(double_quote)
+endif
+ else
+quote=ichar(double_quote)
+endif
+!-----------------------------------------------------------------------------------------------------------------------------------
+before=-2! initially set previous character to impossible value
+unquoted_str(:)=''! initialize output string to null string
+iput=1
+inside=.false.
+STEPTHROUGH:do i=1,inlen
+current=ichar(quoted_str(i:i))
+if(before==iesc)then! if previous character was escape use current character unconditionally
+iput=iput-1! backup
+unquoted_str(iput:iput)=char(current)
+iput=iput+1
+before=-2! this could be second esc or quote
+elseif(current==quote)then! if current is a quote it depends on whether previous character was a quote
+if(before==quote)then
+unquoted_str(iput:iput)=char(quote)! this is second quote so retain it
+iput=iput+1
+before=-2
+elseif(.not.inside.and.before/=iesc)then
+inside=.true.
+else! this is first quote so ignore it except remember it in case next is a quote
+before=current
+endif
+ else
+unquoted_str(iput:iput)=char(current)
+iput=iput+1
+before=current
+endif
+ enddo STEPTHROUGH
+!-----------------------------------------------------------------------------------------------------------------------------------
+unquoted_str=unquoted_str(:iput-1)
+!-----------------------------------------------------------------------------------------------------------------------------------
+end function unquote
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!!
+!! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base
+!! [2-36] to base 10 number
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! logical function decodebase(string,basein,out10)
+!!
+!! character(len=*),intent(in) :: string
+!! integer,intent(in) :: basein
+!! integer,intent(out) :: out10
+!!##DESCRIPTION
+!!
+!! Convert a numeric string representing a whole number in base BASEIN
+!! to base 10. The function returns FALSE if BASEIN is not in the range
+!! [2..36] or if string STRING contains invalid characters in base BASEIN
+!! or if result OUT10 is too big!!
-!! ! the original string
-!! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']'
-!!
-!! ! the string processed by unquote(3f)
-!! unquoted_str=unquote(trim(quoted_str),esc)
-!! write(*,'(a)')'UNQUOTED ['//unquoted_str//']'
-!!
-!! ! read the string list-directed to compare the results
-!! read(quoted_str,*,iostat=ios,iomsg=msg)dummy
-!! if(ios /= 0)then
-!! write(*,*)trim(msg)
-!! else
-!! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']'
-!! endif
-!! enddo
-!! end program demo_unquote
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-pure function unquote(quoted_str,esc)result(unquoted_str)
-character(len=*),intent(in)::quoted_str! the string to be unquoted
-character(len=1),optional,intent(in)::esc! escape character
-character(len=:),allocatable::unquoted_str
-integer::inlen
-character(len=1),parameter::single_quote="'"
-character(len=1),parameter::double_quote='"'
-integer::quote! whichever quote is to be used
-integer::before
-integer::current
-integer::iesc
-integer::iput
-integer::i
-logical::inside
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(present(esc))then! select escape character as specified character or special value meaning not set
-iesc=ichar(esc)! allow for an escape character
-else
-iesc=-1! set to value that matches no character
-endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-inlen=len(quoted_str)! find length of input string
-if(allocated(unquoted_str))deallocate(unquoted_str)
-allocate(character(len=inlen)::unquoted_str)! initially make output string length of input string
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(inlen>=1)then! double_quote is the default quote unless the first character is single_quote
-if(quoted_str(1:1)==single_quote)then
-quote=ichar(single_quote)
-else
-quote=ichar(double_quote)
-endif
- else
-quote=ichar(double_quote)
-endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-before=-2! initially set previous character to impossible value
-unquoted_str(:)=''! initialize output string to null string
-iput=1
-inside=.false.
-STEPTHROUGH:do i=1,inlen
-current=ichar(quoted_str(i:i))
-if(before==iesc)then! if previous character was escape use current character unconditionally
-iput=iput-1! backup
-unquoted_str(iput:iput)=char(current)
-iput=iput+1
-before=-2! this could be second esc or quote
-elseif(current==quote)then! if current is a quote it depends on whether previous character was a quote
-if(before==quote)then
-unquoted_str(iput:iput)=char(quote)! this is second quote so retain it
-iput=iput+1
-before=-2
-elseif(.not.inside.and.before/=iesc)then
-inside=.true.
-else! this is first quote so ignore it except remember it in case next is a quote
-before=current
-endif
- else
-unquoted_str(iput:iput)=char(current)
-iput=iput+1
-before=current
-endif
- enddo STEPTHROUGH
-!-----------------------------------------------------------------------------------------------------------------------------------
-unquoted_str=unquoted_str(:iput-1)
-!-----------------------------------------------------------------------------------------------------------------------------------
-end function unquote
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function i2s(ivalue,fmt)result(outstr)
-
-! ident_22="@(#) M_CLI2 i2s(3fp) private function returns string given integer value"
-
-integer,intent(in)::ivalue! input value to convert to a string
-character(len=*),intent(in),optional::fmt
-character(len=:),allocatable::outstr! output string to generate
-character(len=80)::string
-if(present(fmt))then
- call value_to_string(ivalue,string,fmt=fmt)
-else
- call value_to_string(ivalue,string)
-endif
-outstr=trim(string)
-end function i2s
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! merge_str(3f) - [M_CLI2:LENGTH] pads strings to same length and then
-!! calls MERGE(3f)
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function merge_str(str1,str2,expr) result(strout)
-!!
-!! character(len=*),intent(in),optional :: str1
-!! character(len=*),intent(in),optional :: str2
-!! logical,intent(in) :: expr
-!! character(len=:),allocatable :: strout
-!!##DESCRIPTION
-!! merge_str(3f) pads the shorter of str1 and str2 to the longest length
-!! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr).
-!! It trims trailing spaces off the result and returns the trimmed
-!! string. This makes it easier to call MERGE(3f) with strings, as
-!! MERGE(3f) requires the strings to be the same length.
-!!
-!! NOTE: STR1 and STR2 are always required even though declared optional.
-!! this is so the call "STR_MERGE(A,B,present(A))" is a valid call.
-!! The parameters STR1 and STR2 when they are optional parameters
-!! can be passed to a procedure if the options are optional on the
-!! called procedure.
+!! The letters A,B,...,Z represent 10,11,...,36 in the base > 10.
+!!
+!!##OPTIONS
+!! string input string. It represents a whole number in
+!! the base specified by BASEIN unless BASEIN is set
+!! to zero. When BASEIN is zero STRING is assumed to
+!! be of the form BASE#VALUE where BASE represents
+!! the function normally provided by BASEIN.
+!! basein base of input string; either 0 or from 2 to 36.
+!! out10 output value in base 10
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_decodebase
+!! use M_CLI2, only : codebase, decodebase
+!! implicit none
+!! integer :: ba,bd
+!! character(len=40) :: x,y
+!! integer :: r
+!!
+!! print *,' BASE CONVERSION'
+!! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd
+!! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba
+!! INFINITE: do
+!! print *,''
+!! write(*,'("Enter number in start base: ")',advance='no'); read *, x
+!! if(x == '0') exit INFINITE
+!! if(decodebase(x,bd,r)) then
+!! if(codebase(r,ba,y)) then
+!! write(*,'("In base ",I2,": ",A20)') ba, y
+!! else
+!! print *,'Error in coding number.'
+!! endif
+!! else
+!! print *,'Error in decoding number.'
+!! endif
+!! enddo INFINITE
+!!
+!! end program demo_decodebase
+!!
+!!##AUTHOR
+!! John S. Urban
+!!
+!! Ref.: "Math matiques en Turbo-Pascal by
+!! M. Ducamp and A. Reverchon (2),
+!! Eyrolles, Paris, 1988".
+!!
+!! based on a F90 Version By J-P Moreau (www.jpmoreau.fr)
+!!
+!!##LICENSE
+!! Public Domain
+logical function decodebase(string,basein,out_baseten)
+
+! ident_18="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number"
+
+character(len=*),intent(in)::string
+integer,intent(in)::basein
+integer,intent(out)::out_baseten
+
+character(len=len(string))::string_local
+integer::long,i,j,k
+real::y
+real::mult
+character(len=1)::ch
+real,parameter::XMAXREAL=real(huge(1))
+integer::out_sign
+integer::basein_local
+integer::ipound
+integer::ierr
+
+string_local=upper(trim(adjustl(string)))
+decodebase=.false.
+
+ipound=index(string_local,'#')! determine if in form [-]base#whole
+if(basein==0.and.ipound>1)then! split string into two values
+call a2i(string_local(:ipound-1),basein_local,ierr)! get the decimal value of the base
+string_local=string_local(ipound+1:)! now that base is known make string just the value
+if(basein_local>=0)then! allow for a negative sign prefix
+out_sign=1
+else
+out_sign=-1
+endif
+basein_local=abs(basein_local)
+else! assume string is a simple positive value
+basein_local=abs(basein)
+out_sign=1
+endif
+
+out_baseten=0
+y=0.0
+ALL:if(basein_local<2.or.basein_local>36)then
+ print*,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local
+else ALL
+out_baseten=0;y=0.0;mult=1.0
+long=LEN_TRIM(string_local)
+do i=1,long
+k=long+1-i
+ch=string_local(k:k)
+IF(CH=='-'.AND.K==1)THEN
+out_sign=-1
+cycle
+ endif
+ if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then
+ write(*,*)'*decodebase* ERROR: invalid character ',ch
+exit ALL
+ endif
+ if(ch<='9')then
+j=IACHAR(ch)-IACHAR('0')
+else
+j=IACHAR(ch)-IACHAR('A')+10
+endif
+ if(j>=basein_local)then
+ exit ALL
+ endif
+y=y+mult*j
+if(mult>XMAXREAL/basein_local)then
+ exit ALL
+ endif
+mult=mult*basein_local
+enddo
+decodebase=.true.
+out_baseten=nint(out_sign*y)*sign(1,basein)
+endif ALL
+end function decodebase
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! locate_(3f) - [M_CLI2] finds the index where a string is found or
+!! should be in a sorted array
+!! (LICENSE:PD)!!
-!!##OPTIONS
-!! STR1 string to return if the logical expression EXPR is true
-!! STR2 string to return if the logical expression EXPR is false
-!! EXPR logical expression to evaluate to determine whether to return
-!! STR1 when true, and STR2 when false.
-!!##RESULT
-!! MERGE_STR a trimmed string is returned that is otherwise the value
-!! of STR1 or STR2, depending on the logical expression EXPR.
-!!
-!!##EXAMPLES
+!!##SYNOPSIS
+!!
+!! subroutine locate_(list,value,place,ier,errmsg)
+!!
+!! character(len=:)|doubleprecision|real|integer,allocatable :: list(:)
+!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
+!! integer, intent(out) :: PLACE
+!!
+!! integer, intent(out),optional :: IER
+!! character(len=*),intent(out),optional :: ERRMSG!!
-!! Sample Program:
+!!##DESCRIPTION!!
-!! program demo_merge_str
-!! use M_CLI2, only : merge_str
-!! implicit none
-!! character(len=:), allocatable :: answer
-!! answer=merge_str('first string', 'second string is longer',10 == 10)
-!! write(*,'("[",a,"]")') answer
-!! answer=merge_str('first string', 'second string is longer',10 /= 10)
-!! write(*,'("[",a,"]")') answer
-!! end program demo_merge_str
+!! LOCATE_(3f) finds the index where the VALUE is found or should
+!! be found in an array. The array must be sorted in descending
+!! order (highest at top). If VALUE is not found it returns the index
+!! where the name should be placed at with a negative sign.
+!!
+!! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION,
+!! REAL,INTEGER)
+!!
+!!##OPTIONS!!
-!! Expected output
-!!
-!! [first string]
-!! [second string is longer]
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function merge_str(str1,str2,expr)result(strout)
-! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length
-! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces
-
-! ident_23="@(#) M_CLI2 merge_str(3f) pads first and second arguments to MERGE(3f) to same length"
-
-character(len=*),intent(in),optional::str1
-character(len=*),intent(in),optional::str2
-character(len=:),allocatable::str1_local
-character(len=:),allocatable::str2_local
-logical,intent(in)::expr
-character(len=:),allocatable::strout
-integer::big
-if(present(str2))then
-str2_local=str2
-else
-str2_local=''
-endif
- if(present(str1))then
-str1_local=str1
-else
-str1_local=''
-endif
-big=max(len(str1_local),len(str2_local))
-! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning ''
-strout=trim(merge(lenset(str1_local,big),lenset(str2_local,big),expr))
-end function merge_str
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!!
-!! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base
-!! [2-36] to base 10 number
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! logical function decodebase(string,basein,out10)
-!!
-!! character(len=*),intent(in) :: string
-!! integer,intent(in) :: basein
-!! integer,intent(out) :: out10
-!!##DESCRIPTION
-!!
-!! Convert a numeric string representing a whole number in base BASEIN
-!! to base 10. The function returns FALSE if BASEIN is not in the range
-!! [2..36] or if string STRING contains invalid characters in base BASEIN
-!! or if result OUT10 is too big
-!!
-!! The letters A,B,...,Z represent 10,11,...,36 in the base > 10.
-!!
-!!##OPTIONS
-!! string input string. It represents a whole number in
-!! the base specified by BASEIN unless BASEIN is set
-!! to zero. When BASEIN is zero STRING is assumed to
-!! be of the form BASE#VALUE where BASE represents
-!! the function normally provided by BASEIN.
-!! basein base of input string; either 0 or from 2 to 36.
-!! out10 output value in base 10
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
+!! VALUE the value to locate in the list.
+!! LIST is the list array.
+!!
+!!##RETURNS
+!! PLACE is the subscript that the entry was found at if it is
+!! greater than zero(0).
+!!
+!! If PLACE is negative, the absolute value of
+!! PLACE indicates the subscript value where the
+!! new entry should be placed in order to keep the
+!! list alphabetized.
+!!
+!! IER is zero(0) if no error occurs.
+!! If an error occurs and IER is not
+!! present, the program is stopped.
+!!
+!! ERRMSG description of any error
+!!
+!!##EXAMPLES
+!!
+!!
+!! Find if a string is in a sorted array, and insert the string into
+!! the list if it is not present ...
+!!
+!! program demo_locate
+!! use M_sort, only : sort_shell
+!! use M_CLI2, only : locate_
+!! implicit none
+!! character(len=:),allocatable :: arr(:)
+!! integer :: i
+!!
+!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ]
+!! ! make sure sorted in descending order
+!! call sort_shell(arr,order='d')
+!!
+!! call update_dic(arr,'b')
+!! call update_dic(arr,'[')
+!! call update_dic(arr,'c')
+!! call update_dic(arr,'ZZ')
+!! call update_dic(arr,'ZZZZ')
+!! call update_dic(arr,'z')
+!!
+!! contains
+!! subroutine update_dic(arr,string)
+!! character(len=:),intent(in),allocatable :: arr(:)
+!! character(len=*),intent(in) :: string
+!! integer :: place, plus, ii, end
+!! ! find where string is or should be
+!! call locate_(arr,string,place)
+!! write(*,*)'for "'//string//'" index is ',place, size(arr)
+!! ! if string was not found insert it
+!! if(place < 1)then
+!! plus=abs(place)
+!! ii=len(arr)
+!! end=size(arr)
+!! ! empty array
+!! if(end == 0)then
+!! arr=[character(len=ii) :: string ]
+!! ! put in front of array
+!! elseif(plus == 1)then
+!! arr=[character(len=ii) :: string, arr]
+!! ! put at end of array
+!! elseif(plus == end)then
+!! arr=[character(len=ii) :: arr, string ]
+!! ! put in middle of array
+!! else
+!! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ]
+!! endif
+!! ! show array
+!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
+!! endif
+!! end subroutine update_dic
+!! end program demo_locate!!
-!! program demo_decodebase
-!! use M_CLI2, only : codebase, decodebase
-!! implicit none
-!! integer :: ba,bd
-!! character(len=40) :: x,y
-!! integer :: r
-!!
-!! print *,' BASE CONVERSION'
-!! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd
-!! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba
-!! INFINITE: do
-!! print *,''
-!! write(*,'("Enter number in start base: ")',advance='no'); read *, x
-!! if(x == '0') exit INFINITE
-!! if(decodebase(x,bd,r)) then
-!! if(codebase(r,ba,y)) then
-!! write(*,'("In base ",I2,": ",A20)') ba, y
-!! else
-!! print *,'Error in coding number.'
-!! endif
-!! else
-!! print *,'Error in decoding number.'
-!! endif
-!! enddo INFINITE
-!!
-!! end program demo_decodebase
-!!
-!!##AUTHOR
-!! John S. Urban
-!!
-!! Ref.: "Math matiques en Turbo-Pascal by
-!! M. Ducamp and A. Reverchon (2),
-!! Eyrolles, Paris, 1988".
-!!
-!! based on a F90 Version By J-P Moreau (www.jpmoreau.fr)
-!!
-!!##LICENSE
-!! Public Domain
-logical function decodebase(string,basein,out_baseten)
-
-! ident_24="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number"
-
-character(len=*),intent(in)::string
-integer,intent(in)::basein
-integer,intent(out)::out_baseten
-
-character(len=len(string))::string_local
-integer::long,i,j,k
-real::y
-real::mult
-character(len=1)::ch
-real,parameter::XMAXREAL=real(huge(1))
-integer::out_sign
-integer::basein_local
-integer::ipound
-integer::ierr
-
-string_local=upper(trim(adjustl(string)))
-decodebase=.false.
-
-ipound=index(string_local,'#')! determine if in form [-]base#whole
-if(basein==0.and.ipound>1)then! split string into two values
-call a2i(string_local(:ipound-1),basein_local,ierr)! get the decimal value of the base
-string_local=string_local(ipound+1:)! now that base is known make string just the value
-if(basein_local>=0)then! allow for a negative sign prefix
-out_sign=1
-else
-out_sign=-1
-endif
-basein_local=abs(basein_local)
-else! assume string is a simple positive value
-basein_local=abs(basein)
-out_sign=1
-endif
-
-out_baseten=0
-y=0.0
-ALL:if(basein_local<2.or.basein_local>36)then
- print*,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local
-else ALL
-out_baseten=0;y=0.0;mult=1.0
-long=LEN_TRIM(string_local)
-do i=1,long
-k=long+1-i
-ch=string_local(k:k)
-IF(CH=='-'.AND.K==1)THEN
-out_sign=-1
-cycle
- endif
- if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then
- write(*,*)'*decodebase* ERROR: invalid character ',ch
-exit ALL
- endif
- if(ch<='9')then
-j=IACHAR(ch)-IACHAR('0')
-else
-j=IACHAR(ch)-IACHAR('A')+10
-endif
- if(j>=basein_local)then
- exit ALL
- endif
-y=y+mult*j
-if(mult>XMAXREAL/basein_local)then
- exit ALL
- endif
-mult=mult*basein_local
-enddo
-decodebase=.true.
-out_baseten=nint(out_sign*y)*sign(1,basein)
-endif ALL
-end function decodebase
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! lenset(3f) - [M_CLI2:LENGTH] return string trimmed or padded to
-!! specified length
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function lenset(str,length) result(strout)
-!!
-!! character(len=*) :: str
-!! character(len=length) :: strout
-!! integer,intent(in) :: length
-!!##DESCRIPTION
-!! lenset(3f) truncates a string or pads it with spaces to the specified
-!! length.
-!!##OPTIONS
-!! str input string
-!! length output string length
-!!##RESULTS
-!! strout output string
-!!##EXAMPLE
-!!
-!! Sample Program:
-!!
-!! program demo_lenset
-!! use M_CLI2, only : lenset
-!! implicit none
-!! character(len=10) :: string='abcdefghij'
-!! character(len=:),allocatable :: answer
-!! answer=lenset(string,5)
-!! write(*,'("[",a,"]")') answer
-!! answer=lenset(string,20)
-!! write(*,'("[",a,"]")') answer
-!! end program demo_lenset
-!!
-!! Expected output:
+!! Results:
+!!
+!! for "b" index is 2 5
+!! for "[" index is -4 5
+!! SIZE=5 xxx,b,aaa,[,ZZZ,
+!! for "c" index is -2 6
+!! SIZE=6 xxx,c,b,aaa,[,ZZZ,
+!! for "ZZ" index is -7 7
+!! SIZE=7 xxx,c,b,aaa,[,ZZZ,,
+!! for "ZZZZ" index is -6 8
+!! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,,
+!! for "z" index is -1 9
+!! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,,
+!!
+!!##AUTHOR
+!! 1989,2017 John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine locate_c(list,value,place,ier,errmsg)
+
+! ident_19="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed"
+
+character(len=*),intent(in)::value
+integer,intent(out)::place
+character(len=:),allocatable::list(:)
+integer,intent(out),optional::ier
+character(len=*),intent(out),optional::errmsg
+integer::i
+character(len=:),allocatable::message
+integer::arraysize
+integer::maxtry
+integer::imin,imax
+integer::error
+if(.not.allocated(list))then
+list=[character(len=max(len_trim(value),2))::]
+endif
+arraysize=size(list)
+
+error=0
+if(arraysize==0)then
+maxtry=0
+place=-1
+else
+maxtry=nint(log(float(arraysize))/log(2.0)+1.0)
+place=(arraysize+1)/2
+endif
+imin=1
+imax=arraysize
+message=''
+
+LOOP:block
+ do i=1,maxtry
+
+if(value==list(PLACE))then
+ exit LOOP
+elseif(value>list(place))then
+imax=place-1
+else
+imin=place+1
+endif
+
+ if(imin>imax)then
+place=-imin
+if(iabs(place)>arraysize)then! ran off end of list. Where new value should go or an unsorted input array'
+exit LOOP
+endif
+ exit LOOP
+endif
+
+place=(imax+imin)/2
+
+if(place>arraysize.or.place<=0)then
+message='*locate_* error: search is out of bounds of list. Probably an unsorted input array'
+error=-1
+exit LOOP
+endif
+
+ enddo
+message='*locate_* exceeded allowed tries. Probably an unsorted input array'
+endblock LOOP
+if(present(ier))then
+ier=error
+elseif(error/=0)then
+ write(warn,*)message//' VALUE=',trim(value)//' PLACE=',place
+call mystop(-24,'(*locate_c* '//message)
+endif
+ if(present(errmsg))then
+errmsg=message
+endif
+end subroutine locate_c
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine remove_(list,place)
+!!
+!! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:)
+!! integer, intent(out) :: PLACE
+!!
+!!##DESCRIPTION
+!!
+!! Remove a value from an allocatable array at the specified index.
+!! The array is assumed to be sorted in descending order. It may be of
+!! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER.
+!!
+!!##OPTIONS
+!!
+!! list is the list array.
+!! PLACE is the subscript for the entry that should be removed
+!!
+!!##EXAMPLES
+!!
+!!
+!! Sample program
+!!
+!! program demo_remove
+!! use M_sort, only : sort_shell
+!! use M_CLI2, only : locate_, remove_
+!! implicit none
+!! character(len=:),allocatable :: arr(:)
+!! integer :: i
+!! integer :: end
+!!
+!! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ]
+!! ! make sure sorted in descending order
+!! call sort_shell(arr,order='d')
+!!
+!! end=size(arr)
+!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
+!! call remove_(arr,1)
+!! end=size(arr)
+!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
+!! call remove_(arr,4)
+!! end=size(arr)
+!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
+!!
+!! end program demo_remove
+!!
+!! Results:
+!!
+!! Expected output
+!!
+!! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,,
+!! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,,
+!! SIZE=7 bb,b,b,aaa,ZZZ,Z,,!!
-!! [abcde]
-!! [abcdefghij ]
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function lenset(line,length)result(strout)
-
-! ident_25="@(#) M_CLI2 lenset(3f) return string trimmed or padded to specified length"
-
-character(len=*),intent(in)::line
-integer,intent(in)::length
-character(len=length)::strout
-strout=line
-end function lenset
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! value_to_string(3f) - [M_CLI2:NUMERIC] return numeric string from
-!! a numeric value
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine value_to_string(value,chars[,iilen,ierr,fmt,trimz])
-!!
-!! character(len=*) :: chars ! minimum of 23 characters required
-!! !--------
-!! ! VALUE may be any <em>one</em> of the following types:
-!! doubleprecision,intent(in) :: value
-!! real,intent(in) :: value
-!! integer,intent(in) :: value
-!! logical,intent(in) :: value
-!! !--------
-!! character(len=*),intent(out) :: chars
-!! integer,intent(out),optional :: iilen
-!! integer,optional :: ierr
-!! character(len=*),intent(in),optional :: fmt
-!! logical,intent(in) :: trimz
-!!
-!!##DESCRIPTION
-!! value_to_string(3f) returns a numeric representation of a numeric
-!! value in a string given a numeric value of type REAL, DOUBLEPRECISION,
-!! INTEGER or LOGICAL. It creates the string using internal writes. It
-!! then removes trailing zeros from non-zero values, and left-justifies
-!! the string.
-!!
-!!##OPTIONS
-!! VALUE input value to be converted to a string
-!! FMT You may specify a specific format that produces a string
-!! up to the length of CHARS; optional.
-!! TRIMZ If a format is supplied the default is not to try to trim
-!! trailing zeros. Set TRIMZ to .true. to trim zeros from a
-!! string assumed to represent a simple numeric value.
-!!
-!!##RETURNS
-!! CHARS returned string representing input value, must be at least
-!! 23 characters long; or what is required by optional FMT
-!! if longer.
-!! IILEN position of last non-blank character in returned string;
-!! optional.
-!! IERR If not zero, error occurred; optional.
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_value_to_string
-!! use M_CLI2, only: value_to_string
-!! implicit none
-!! character(len=80) :: string
-!! integer :: iilen
-!! call value_to_string(3.0/4.0,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(3.0/4.0,string,iilen,fmt='')
-!! write(*,*) 'The value is [',string(:iilen),']'
+!!##AUTHOR
+!! 1989,2017 John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine remove_c(list,place)
+
+! ident_20="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position"
+
+character(len=:),allocatable::list(:)
+integer,intent(in)::place
+integer::ii,end
+ if(.not.allocated(list))then
+list=[character(len=2)::]
+endif
+ii=len(list)
+end=size(list)
+if(place<=0.or.place>end)then! index out of bounds of array
+elseif(place==end)then! remove from array
+list=[character(len=ii)::list(:place-1)]
+else
+list=[character(len=ii)::list(:place-1),list(place+1:)]
+endif
+end subroutine remove_c
+subroutine remove_l(list,place)
+
+! ident_21="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position"
+
+logical,allocatable::list(:)
+integer,intent(in)::place
+integer::end
+
+ if(.not.allocated(list))then
+list=[logical::]
+endif
+ end=size(list)
+if(place<=0.or.place>end)then! index out of bounds of array
+elseif(place==end)then! remove from array
+list=[list(:place-1)]
+else
+list=[list(:place-1),list(place+1:)]
+endif
+
+end subroutine remove_l
+subroutine remove_i(list,place)
+
+! ident_22="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position"
+integer,allocatable::list(:)
+integer,intent(in)::place
+integer::end
+
+ if(.not.allocated(list))then
+list=[integer::]
+endif
+ end=size(list)
+if(place<=0.or.place>end)then! index out of bounds of array
+elseif(place==end)then! remove from array
+list=[list(:place-1)]
+else
+list=[list(:place-1),list(place+1:)]
+endif
+
+end subroutine remove_i
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! replace_(3f) - [M_CLI2] replace entry in a string array at specified position
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine replace_(list,value,place)
+!!
+!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
+!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:)
+!! integer, intent(out) :: place
+!!
+!!##DESCRIPTION!!
-!! call value_to_string(3.0/4.0,string,iilen,fmt='("THE VALUE IS ",g0)')
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(1234,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(1.0d0/3.0d0,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
+!! replace a value in an allocatable array at the specified index. Unless the
+!! array needs the string length to increase this is merely an assign of a value
+!! to an array element.
+!!
+!! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER>
+!! It is assumed to be sorted in descending order without duplicate values.
+!!
+!! The value and list must be of the same type.!!
-!! end program demo_value_to_string
+!!##OPTIONS!!
-!! Expected output
-!!
-!! The value is [0.75]
-!! The value is [ 0.7500000000]
-!! The value is [THE VALUE IS .750000000]
-!! The value is [1234]
-!! The value is [0.33333333333333331]
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine value_to_string(gval,chars,length,err,fmt,trimz)
-
-! ident_26="@(#) M_CLI2 value_to_string(3fp) subroutine returns a string from a value"
-
-class(*),intent(in)::gval
-character(len=*),intent(out)::chars
-integer,intent(out),optional::length
-integer,optional::err
-integer::err_local
-character(len=*),optional,intent(in)::fmt! format to write value with
-logical,intent(in),optional::trimz
-character(len=:),allocatable::fmt_local
-character(len=1024)::msg
-
-! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL)
-
-if(present(fmt))then
- select type(gval)
-type is(integer)
-fmt_local='(i0)'
-if(fmt/='')fmt_local=fmt
-write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
-type is(real)
-fmt_local='(bz,g23.10e3)'
-fmt_local='(bz,g0.8)'
-if(fmt/='')fmt_local=fmt
-write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
-type is(doubleprecision)
-fmt_local='(bz,g0)'
-if(fmt/='')fmt_local=fmt
-write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
-type is(logical)
-fmt_local='(l1)'
-if(fmt/='')fmt_local=fmt
-write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
-class default
-call journal('sc','*value_to_string* UNKNOWN TYPE')
-chars=' '
-end select
- if(fmt=='')then
-chars=adjustl(chars)
-call trimzeros_(chars)
-endif
- else! no explicit format option present
-err_local=-1
-select type(gval)
-type is(integer)
-write(chars,*,iostat=err_local,iomsg=msg)gval
-type is(real)
-write(chars,*,iostat=err_local,iomsg=msg)gval
-type is(doubleprecision)
-write(chars,*,iostat=err_local,iomsg=msg)gval
-type is(logical)
-write(chars,*,iostat=err_local,iomsg=msg)gval
-class default
-chars=''
-end select
-chars=adjustl(chars)
-if(index(chars,'.')/=0)call trimzeros_(chars)
-endif
- if(present(trimz))then
- if(trimz)then
-chars=adjustl(chars)
-call trimzeros_(chars)
-endif
- endif
-
- if(present(length))then
-length=len_trim(chars)
-endif
-
- if(present(err))then
-err=err_local
-elseif(err_local/=0)then
-!-! cannot currently do I/O from a function being called from I/O
-!-!write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']'
-chars=chars//' *value_to_string* WARNING:['//trim(msg)//']'
-endif
-
-end subroutine value_to_string
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! trimzeros_(3fp) - [M_CLI2:NUMERIC] Delete trailing zeros from numeric
-!! `decimal string
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine trimzeros_(str)
-!!
-!! character(len=*) :: str
-!!##DESCRIPTION
-!! TRIMZEROS_(3f) deletes trailing zeros from a string representing a
-!! number. If the resulting string would end in a decimal point, one
-!! trailing zero is added.
-!!##OPTIONS
-!! str input string will be assumed to be a numeric value and have
-!! trailing zeros removed
-!!##EXAMPLES
-!!
-!! Sample program:
-!!
-!! program demo_trimzeros_
-!! use M_CLI2, only : trimzeros_
-!! character(len=:),allocatable :: string
-!! write(*,*)trimzeros_('123.450000000000')
-!! write(*,*)trimzeros_('12345')
-!! write(*,*)trimzeros_('12345.')
-!! write(*,*)trimzeros_('12345.00e3')
-!! end program demo_trimzeros_
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine trimzeros_(string)
-
-! ident_27="@(#) M_CLI2 trimzeros_(3fp) Delete trailing zeros from numeric decimal string"
-
-! if zero needs added at end assumes input string has room
-character(len=*)::string
-character(len=len(string)+2)::str
-character(len=len(string))::expo! the exponent string if present
-integer::ipos! where exponent letter appears if present
-integer::i,ii
-str=string! working copy of string
-ipos=scan(str,'eEdD')! find end of real number if string uses exponent notation
-if(ipos>0)then! letter was found
-expo=str(ipos:)! keep exponent string so it can be added back as a suffix
-str=str(1:ipos-1)! just the real part, exponent removed will not have trailing zeros removed
-endif
- if(index(str,'.')==0)then! if no decimal character in original string add one to end of string
-ii=len_trim(str)
-str(ii+1:ii+1)='.'! add decimal to end of string
-endif
- do i=len_trim(str),1,-1! scanning from end find a non-zero character
-select case(str(i:i))
-case('0')! found a trailing zero so keep trimming
-cycle
- case('.')! found a decimal character at end of remaining string
-if(i<=1)then
-str='0'
-else
-str=str(1:i-1)
-endif
- exit
- case default
-str=str(1:i)! found a non-zero character so trim string and exit
-exit
- end select
- end do
- if(ipos>0)then! if originally had an exponent place it back on
-string=trim(str)//trim(expo)
-else
-string=str
-endif
-end subroutine trimzeros_
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! substitute(3f) - [M_CLI2:EDITING] subroutine globally substitutes
-!! one substring for another in string
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine substitute(targetline,old,new,ierr,start,end)
-!!
-!! character(len=*) :: targetline
-!! character(len=*),intent(in) :: old
-!! character(len=*),intent(in) :: new
-!! integer,intent(out),optional :: ierr
-!! integer,intent(in),optional :: start
-!! integer,intent(in),optional :: end
-!!##DESCRIPTION
-!! Globally substitute one substring for another in string.
-!!
-!!##OPTIONS
-!! TARGETLINE input line to be changed. Must be long enough to
-!! hold altered output.
-!! OLD substring to find and replace
-!! NEW replacement for OLD substring
-!! IERR error code. If IER = -1 bad directive, >= 0 then
-!! count of changes made.
-!! START sets the left margin to be scanned for OLD in
-!! TARGETLINE.
-!! END sets the right margin to be scanned for OLD in
-!! TARGETLINE.
+!! VALUE the value to place in the array
+!! LIST is the array.
+!! PLACE is the subscript that the entry should be placed at
+!!
+!!##EXAMPLES
+!!
+!!
+!! Replace key-value pairs in a dictionary
+!!
+!! program demo_replace
+!! use M_CLI2, only : insert_, locate_, replace_
+!! ! Find if a key is in a list and insert it
+!! ! into the key list and value list if it is not present
+!! ! or replace the associated value if the key existed
+!! implicit none
+!! character(len=20) :: key
+!! character(len=100) :: val
+!! character(len=:),allocatable :: keywords(:)
+!! character(len=:),allocatable :: values(:)
+!! integer :: i
+!! integer :: place
+!! call update_dic('b','value of b')
+!! call update_dic('a','value of a')
+!! call update_dic('c','value of c')
+!! call update_dic('c','value of c again')
+!! call update_dic('d','value of d')
+!! call update_dic('a','value of a again')
+!! ! show array
+!! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords))
+!!
+!! call locate_key('a',place)
+!! if(place > 0)then
+!! write(*,*)'The value of "a" is',trim(values(place))
+!! else
+!! write(*,*)'"a" not found'
+!! endif
+!!
+!! contains
+!! subroutine update_dic(key,val)
+!! character(len=*),intent(in) :: key
+!! character(len=*),intent(in) :: val
+!! integer :: place
+!!
+!! ! find where string is or should be
+!! call locate_key(key,place)
+!! ! if string was not found insert it
+!! if(place < 1)then
+!! call insert_(keywords,key,abs(place))
+!! call insert_(values,val,abs(place))
+!! else ! replace
+!! call replace_(values,val,place)
+!! endif
+!!
+!! end subroutine update_dic
+!! end program demo_replace
+!!
+!! Expected output
+!!
+!! d==>value of d
+!! c==>value of c again
+!! b==>value of b
+!! a==>value of a again
+!!
+!!##AUTHOR
+!! 1989,2017 John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine replace_c(list,value,place)
+
+! ident_23="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position"
+
+character(len=*),intent(in)::value
+character(len=:),allocatable::list(:)
+character(len=:),allocatable::kludge(:)
+integer,intent(in)::place
+integer::ii
+integer::tlen
+integer::end
+ if(.not.allocated(list))then
+list=[character(len=max(len_trim(value),2))::]
+endif
+tlen=len_trim(value)
+end=size(list)
+if(place<0.or.place>end)then
+ write(warn,*)'*replace_c* error: index out of range. end=',end,' index=',place
+elseif(len_trim(value)<=len(list))then
+list(place)=value
+ else! increase length of variable
+ii=max(tlen,len(list))
+kludge=[character(len=ii)::list]
+list=kludge
+list(place)=value
+ endif
+end subroutine replace_c
+subroutine replace_l(list,value,place)
+
+! ident_24="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position"
+
+logical,allocatable::list(:)
+logical,intent(in)::value
+integer,intent(in)::place
+integer::end
+ if(.not.allocated(list))then
+list=[logical::]
+endif
+ end=size(list)
+if(end==0)then! empty array
+list=[value]
+elseif(place>0.and.place<=end)then
+list(place)=value
+ else! put in middle of array
+write(warn,*)'*replace_l* error: index out of range. end=',end,' index=',place
+endif
+end subroutine replace_l
+subroutine replace_i(list,value,place)
+
+! ident_25="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position"
+
+integer,intent(in)::value
+integer,allocatable::list(:)
+integer,intent(in)::place
+integer::end
+ if(.not.allocated(list))then
+list=[integer::]
+endif
+ end=size(list)
+if(end==0)then! empty array
+list=[value]
+elseif(place>0.and.place<=end)then
+list(place)=value
+ else! put in middle of array
+write(warn,*)'*replace_i* error: index out of range. end=',end,' index=',place
+endif
+end subroutine replace_i
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+!>
+!!##NAME
+!! insert_(3f) - [M_CLI2] insert entry into a string array at specified position
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine insert_(list,value,place)
+!!
+!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
+!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:)
+!! integer,intent(in) :: place
+!!
+!!##DESCRIPTION
+!!
+!! Insert a value into an allocatable array at the specified index.
+!! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION,
+!! REAL, or INTEGER)
+!!
+!!##OPTIONS
+!!
+!! list is the list array. Must be sorted in descending order.
+!! value the value to place in the array
+!! PLACE is the subscript that the entry should be placed at
+!!
+!!##EXAMPLES
+!!
+!!
+!! Find if a string is in a sorted array, and insert the string into
+!! the list if it is not present ...
+!!
+!! program demo_insert
+!! use M_sort, only : sort_shell
+!! use M_CLI2, only : locate_, insert_
+!! implicit none
+!! character(len=:),allocatable :: arr(:)
+!! integer :: i
+!!
+!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ]
+!! ! make sure sorted in descending order
+!! call sort_shell(arr,order='d')
+!! ! add or replace values
+!! call update_dic(arr,'b')
+!! call update_dic(arr,'[')
+!! call update_dic(arr,'c')
+!! call update_dic(arr,'ZZ')
+!! call update_dic(arr,'ZZZ')
+!! call update_dic(arr,'ZZZZ')
+!! call update_dic(arr,'')
+!! call update_dic(arr,'z')
+!!
+!! contains
+!! subroutine update_dic(arr,string)
+!! character(len=:),allocatable :: arr(:)
+!! character(len=*) :: string
+!! integer :: place, end
+!!
+!! end=size(arr)
+!! ! find where string is or should be
+!! call locate_(arr,string,place)
+!! ! if string was not found insert it
+!! if(place < 1)then
+!! call insert_(arr,string,abs(place))
+!! endif
+!! ! show array
+!! end=size(arr)
+!! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)!!
-!!##EXAMPLES
-!!
-!! Sample Program:
-!!
-!! program demo_substitute
-!! use M_CLI2, only : substitute
-!! implicit none
-!! ! must be long enough to hold changed line
-!! character(len=80) :: targetline
-!!
-!! targetline='this is the input string'
-!! write(*,*)'ORIGINAL : '//trim(targetline)
-!!
-!! ! changes the input to 'THis is THe input string'
-!! call substitute(targetline,'th','TH')
-!! write(*,*)'th => TH : '//trim(targetline)
-!!
-!! ! a null old substring means "at beginning of line"
-!! ! changes the input to 'BEFORE:this is the input string'
-!! call substitute(targetline,'','BEFORE:')
-!! write(*,*)'"" => BEFORE: '//trim(targetline)
-!!
-!! ! a null new string deletes occurrences of the old substring
-!! ! changes the input to 'ths s the nput strng'
-!! call substitute(targetline,'i','')
-!! write(*,*)'i => "" : '//trim(targetline)
-!!
-!! end program demo_substitute
-!!
-!! Expected output
-!!
-!! ORIGINAL : this is the input string
-!! th => TH : THis is THe input string
-!! "" => BEFORE: BEFORE:THis is THe input string
-!! i => "" : BEFORE:THs s THe nput strng
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine substitute(targetline,old,new,ierr,start,end)
-
-! ident_28="@(#) M_CLI2 substitute(3f) Globally substitute one substring for another in string"
-
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=*)::targetline! input line to be changed
-character(len=*),intent(in)::old! old substring to replace
-character(len=*),intent(in)::new! new substring
-integer,intent(out),optional::ierr! error code. If ierr = -1 bad directive, >=0 then ierr changes made
-integer,intent(in),optional::start! start sets the left margin
-integer,intent(in),optional::end! end sets the right margin
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=len(targetline))::dum1! scratch string buffers
-integer::ml,mr,ier1
-integer::maxlengthout! MAXIMUM LENGTH ALLOWED FOR NEW STRING
-integer::original_input_length
-integer::len_old,len_new
-integer::ladd
-integer::ir
-integer::ind
-integer::il
-integer::id
-integer::ic
-integer::iichar
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(present(start))then! optional starting column
-ml=start
-else
-ml=1
-endif
- if(present(end))then! optional ending column
-mr=end
- else
-mr=len(targetline)
-endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-ier1=0! initialize error flag/change count
-maxlengthout=len(targetline)! max length of output string
-original_input_length=len_trim(targetline)! get non-blank length of input line
-dum1(:)=' '! initialize string to build output in
-id=mr-ml! check for window option !-! change to optional parameter(s)
-!-----------------------------------------------------------------------------------------------------------------------------------
-len_old=len(old)! length of old substring to be replaced
-len_new=len(new)! length of new substring to replace old substring
-if(id<=0)then! no window so change entire input string
-il=1! il is left margin of window to change
-ir=maxlengthout! ir is right margin of window to change
-dum1(:)=' '! begin with a blank line
-else! if window is set
-il=ml! use left margin
-ir=min0(mr,maxlengthout)! use right margin or rightmost
-dum1=targetline(:il-1)! begin with what's below margin
-endif! end of window settings
-!-----------------------------------------------------------------------------------------------------------------------------------
-if(len_old==0)then! c//new/ means insert new at beginning of line (or left margin)
-iichar=len_new+original_input_length
-if(iichar>maxlengthout)then
- call journal('sc','*substitute* new line will be too long')
-ier1=-1
-if(present(ierr))ierr=ier1
-return
- endif
- if(len_new>0)then
-dum1(il:)=new(:len_new)//targetline(il:original_input_length)
-else
-dum1(il:)=targetline(il:original_input_length)
-endif
-targetline(1:maxlengthout)=dum1(:maxlengthout)
-ier1=1! made one change. actually, c/// should maybe return 0
-if(present(ierr))ierr=ier1
-return
- endif
-!-----------------------------------------------------------------------------------------------------------------------------------
-iichar=il! place to put characters into output string
-ic=il! place looking at in input string
-loop:do
-ind=index(targetline(ic:),old(:len_old))+ic-1! try to find start of old string in remaining part of input in change window
-if(ind==ic-1.or.ind>ir)then! did not find old string or found old string past edit window
-exit loop! no more changes left to make
-endif
-ier1=ier1+1! found an old string to change, so increment count of changes
-if(ind>ic)then! if found old string past at current position in input string copy unchanged
-ladd=ind-ic! find length of character range to copy as-is from input to output
-if(iichar-1+ladd>maxlengthout)then
-ier1=-1
-exit loop
-endif
-dum1(iichar:)=targetline(ic:ind-1)
-iichar=iichar+ladd
-endif
- if(iichar-1+len_new>maxlengthout)then
-ier1=-2
-exit loop
-endif
- if(len_new/=0)then
-dum1(iichar:)=new(:len_new)
-iichar=iichar+len_new
-endif
-ic=ind+len_old
-enddo loop
-!-----------------------------------------------------------------------------------------------------------------------------------
-select case(ier1)
-case(:-1)
-call journal('sc','*substitute* new line will be too long')
-case(0)! there were no changes made to the window
-case default
-ladd=original_input_length-ic
-if(iichar+ladd>maxlengthout)then
- call journal('sc','*substitute* new line will be too long')
-ier1=-1
-if(present(ierr))ierr=ier1
-return
- endif
- if(ic<len(targetline))then
-dum1(iichar:)=targetline(ic:max(ic,original_input_length))
-endif
-targetline=dum1(:maxlengthout)
-end select
- if(present(ierr))ierr=ier1
-!-----------------------------------------------------------------------------------------------------------------------------------
-end subroutine substitute
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!! end subroutine update_dic
+!! end program demo_insert
+!!
+!! Results:
+!!
+!! array is now SIZE=5 xxx,b,aaa,ZZZ,,
+!! array is now SIZE=6 xxx,b,aaa,[,ZZZ,,
+!! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,,
+!! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,,
+!! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,,
+!! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,,
+!!
+!!##AUTHOR
+!! 1989,2017 John S. Urban
+!!##LICENSE
+!! Public Domain
+subroutine insert_c(list,value,place)
+
+! ident_26="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position"
+
+character(len=*),intent(in)::value
+character(len=:),allocatable::list(:)
+character(len=:),allocatable::kludge(:)
+integer,intent(in)::place
+integer::ii
+integer::end
+
+ if(.not.allocated(list))then
+list=[character(len=max(len_trim(value),2))::]
+endif
+
+ii=max(len_trim(value),len(list),2)
+end=size(list)
+
+if(end==0)then! empty array
+list=[character(len=ii)::value]
+elseif(place==1)then! put in front of array
+kludge=[character(len=ii)::value,list]
+list=kludge
+elseif(place>end)then! put at end of array
+kludge=[character(len=ii)::list,value]
+list=kludge
+elseif(place>=2.and.place<=end)then! put in middle of array
+kludge=[character(len=ii)::list(:place-1),value,list(place:)]
+list=kludge
+else! index out of range
+write(warn,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value
+ endif
+
+end subroutine insert_c
+subroutine insert_l(list,value,place)
+
+! ident_27="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position"
+
+logical,allocatable::list(:)
+logical,intent(in)::value
+integer,intent(in)::place
+integer::end
+ if(.not.allocated(list))then
+list=[logical::]
+endif
+ end=size(list)
+if(end==0)then! empty array
+list=[value]
+elseif(place==1)then! put in front of array
+list=[value,list]
+elseif(place>end)then! put at end of array
+list=[list,value]
+elseif(place>=2.and.place<=end)then! put in middle of array
+list=[list(:place-1),value,list(place:)]
+else! index out of range
+write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value
+ endif
+
+end subroutine insert_l
+subroutine insert_i(list,value,place)
+
+! ident_28="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position"
+
+integer,allocatable::list(:)
+integer,intent(in)::value
+integer,intent(in)::place
+integer::end
+ if(.not.allocated(list))then
+list=[integer::]
+endif
+ end=size(list)
+if(end==0)then! empty array
+list=[value]
+elseif(place==1)then! put in front of array
+list=[value,list]
+elseif(place>end)then! put at end of array
+list=[list,value]
+elseif(place>=2.and.place<=end)then! put in middle of array
+list=[list(:place-1),value,list(place:)]
+else! index out of range
+write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value
+ endif
+
+end subroutine insert_i
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+subroutine many_args(n0,g0,n1,g1,n2,g2,n3,g3,n4,g4,n5,g5,n6,g6,n7,g7,n8,g8,n9,g9,&
+&na,ga,nb,gb,nc,gc,nd,gd,ne,ge,nf,gf,ng,gg,nh,gh,ni,gi,nj,gj)
+
+! ident_29="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)"
+
+character(len=*),intent(in)::n0,n1
+character(len=*),intent(in),optional::n2,n3,n4,n5,n6,n7,n8,n9,na,nb,nc,nd,ne,nf,ng,nh,ni,nj
+class(*),intent(out)::g0,g1
+class(*),intent(out),optional::g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
+call get_generic(n0,g0)
+call get_generic(n1,g1)
+if(present(n2).and.present(g2))call get_generic(n2,g2)
+if(present(n3).and.present(g3))call get_generic(n3,g3)
+if(present(n4).and.present(g4))call get_generic(n4,g4)
+if(present(n5).and.present(g5))call get_generic(n5,g5)
+if(present(n6).and.present(g6))call get_generic(n6,g6)
+if(present(n7).and.present(g7))call get_generic(n7,g7)
+if(present(n8).and.present(g8))call get_generic(n8,g8)
+if(present(n9).and.present(g9))call get_generic(n9,g9)
+if(present(na).and.present(ga))call get_generic(na,ga)
+if(present(nb).and.present(gb))call get_generic(nb,gb)
+if(present(nc).and.present(gc))call get_generic(nc,gc)
+if(present(nd).and.present(gd))call get_generic(nd,gd)
+if(present(ne).and.present(ge))call get_generic(ne,ge)
+if(present(nf).and.present(gf))call get_generic(nf,gf)
+if(present(ng).and.present(gg))call get_generic(ng,gg)
+if(present(nh).and.present(gh))call get_generic(nh,gh)
+if(present(ni).and.present(gi))call get_generic(ni,gi)
+if(present(nj).and.present(gj))call get_generic(nj,gj)
+contains
+!===================================================================================================================================
+function c(generic)
+class(*),intent(in)::generic
+character(len=:),allocatable::c
+select type(generic)
+type is(character(len=*));c=trim(generic)
+class default
+c='unknown'
+stop'get_many:: parameter name is not character'
+end select
+end function c
+!===================================================================================================================================
+subroutine get_generic(name,generic)
+use,intrinsic::iso_fortran_env,only:real64
+character(len=*),intent(in)::name
+class(*),intent(out)::generic
+ select type(generic)
+type is(integer);call get_args(name,generic)
+type is(real);call get_args(name,generic)
+type is(real(kind=real64));call get_args(name,generic)
+type is(logical);call get_args(name,generic)
+!x!type is (character(len=:),allocatable ::); call get_args(name,generic)
+type is(character(len=*));
+call get_args_fixed_length(name,generic)
+type is(complex);call get_args(name,generic)
+class default
+stop'unknown type in *get_generic*'
+end select
+end subroutine get_generic!===================================================================================================================================
-!>
-!!##NAME
-!! locate_(3f) - [M_CLI2] finds the index where a string is found or
-!! should be in a sorted array
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine locate_(list,value,place,ier,errmsg)
-!!
-!! character(len=:)|doubleprecision|real|integer,allocatable :: list(:)
-!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
-!! integer, intent(out) :: PLACE
-!!
-!! integer, intent(out),optional :: IER
-!! character(len=*),intent(out),optional :: ERRMSG
-!!
-!!##DESCRIPTION
-!!
-!! LOCATE_(3f) finds the index where the VALUE is found or should
-!! be found in an array. The array must be sorted in descending
-!! order (highest at top). If VALUE is not found it returns the index
-!! where the name should be placed at with a negative sign.
-!!
-!! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION,
-!! REAL,INTEGER)
-!!
-!!##OPTIONS
-!!
-!! VALUE the value to locate in the list.
-!! LIST is the list array.
-!!
-!!##RETURNS
-!! PLACE is the subscript that the entry was found at if it is
-!! greater than zero(0).
-!!
-!! If PLACE is negative, the absolute value of
-!! PLACE indicates the subscript value where the
-!! new entry should be placed in order to keep the
-!! list alphabetized.
-!!
-!! IER is zero(0) if no error occurs.
-!! If an error occurs and IER is not
-!! present, the program is stopped.
-!!
-!! ERRMSG description of any error
-!!
-!!##EXAMPLES
-!!
-!!
-!! Find if a string is in a sorted array, and insert the string into
-!! the list if it is not present ...
-!!
-!! program demo_locate
-!! use M_sort, only : sort_shell
-!! use M_CLI2, only : locate_
-!! implicit none
-!! character(len=:),allocatable :: arr(:)
-!! integer :: i
-!!
-!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ]
-!! ! make sure sorted in descending order
-!! call sort_shell(arr,order='d')
-!!
-!! call update(arr,'b')
-!! call update(arr,'[')
-!! call update(arr,'c')
-!! call update(arr,'ZZ')
-!! call update(arr,'ZZZZ')
-!! call update(arr,'z')
-!!
-!! contains
-!! subroutine update(arr,string)
-!! character(len=:),intent(in),allocatable :: arr(:)
-!! character(len=*),intent(in) :: string
-!! integer :: place, plus, ii, end
-!! ! find where string is or should be
-!! call locate_(arr,string,place)
-!! write(*,*)'for "'//string//'" index is ',place, size(arr)
-!! ! if string was not found insert it
-!! if(place < 1)then
-!! plus=abs(place)
-!! ii=len(arr)
-!! end=size(arr)
-!! ! empty array
-!! if(end == 0)then
-!! arr=[character(len=ii) :: string ]
-!! ! put in front of array
-!! elseif(plus == 1)then
-!! arr=[character(len=ii) :: string, arr]
-!! ! put at end of array
-!! elseif(plus == end)then
-!! arr=[character(len=ii) :: arr, string ]
-!! ! put in middle of array
-!! else
-!! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ]
-!! endif
-!! ! show array
-!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
-!! endif
-!! end subroutine update
-!! end program demo_locate
-!!
-!! Results:
-!!
-!! for "b" index is 2 5
-!! for "[" index is -4 5
-!! SIZE=5 xxx,b,aaa,[,ZZZ,
-!! for "c" index is -2 6
-!! SIZE=6 xxx,c,b,aaa,[,ZZZ,
-!! for "ZZ" index is -7 7
-!! SIZE=7 xxx,c,b,aaa,[,ZZZ,,
-!! for "ZZZZ" index is -6 8
-!! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,,
-!! for "z" index is -1 9
-!! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,,
-!!
-!!##AUTHOR
-!! 1989,2017 John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine locate_c(list,value,place,ier,errmsg)
-
-! ident_29="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed"
-
-character(len=*),intent(in)::value
-integer,intent(out)::place
-character(len=:),allocatable::list(:)
-integer,intent(out),optional::ier
-character(len=*),intent(out),optional::errmsg
-integer::i
-character(len=:),allocatable::message
-integer::arraysize
-integer::maxtry
-integer::imin,imax
-integer::error
-if(.not.allocated(list))then
-list=[character(len=max(len_trim(value),2))::]
-endif
-arraysize=size(list)
-
-error=0
-if(arraysize==0)then
-maxtry=0
-place=-1
-else
-maxtry=nint(log(float(arraysize))/log(2.0)+1.0)
-place=(arraysize+1)/2
-endif
-imin=1
-imax=arraysize
-message=''
-
-LOOP:block
- do i=1,maxtry
-
-if(value==list(PLACE))then
- exit LOOP
-elseif(value>list(place))then
-imax=place-1
-else
-imin=place+1
-endif
-
- if(imin>imax)then
-place=-imin
-if(iabs(place)>arraysize)then! ran off end of list. Where new value should go or an unsorted input array'
-exit LOOP
-endif
- exit LOOP
-endif
-
-place=(imax+imin)/2
-
-if(place>arraysize.or.place<=0)then
-message='*locate_* error: search is out of bounds of list. Probably an unsorted input array'
-error=-1
-exit LOOP
-endif
-
- enddo
-message='*locate_* exceeded allowed tries. Probably an unsorted input array'
-endblock LOOP
-if(present(ier))then
-ier=error
-elseif(error/=0)then
- write(warn,*)message//' VALUE=',trim(value)//' PLACE=',place
-call mystop(-24,'(*locate_c* '//message)
-endif
- if(present(errmsg))then
-errmsg=message
-endif
-end subroutine locate_c
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine remove_(list,place)
-!!
-!! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:)
-!! integer, intent(out) :: PLACE
+end subroutine many_args
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+function iget(n);integer::iget;character(len=*),intent(in)::n;call get_args(n,iget);end function iget
+function rget(n);real::rget;character(len=*),intent(in)::n;call get_args(n,rget);end function rget
+function dget(n);real(kind=dp)::dget;character(len=*),intent(in)::n;call get_args(n,dget);end function dget
+function sget(n);character(len=:),allocatable::sget;character(len=*),intent(in)::n;call get_args(n,sget);end function sget
+function cget(n);complex::cget;character(len=*),intent(in)::n;call get_args(n,cget);end function cget
+function lget(n);logical::lget;character(len=*),intent(in)::n;call get_args(n,lget);end function lget
+
+function igs(n);integer,allocatable::igs(:);character(len=*),intent(in)::n;call get_args(n,igs);end function igs
+function rgs(n);real,allocatable::rgs(:);character(len=*),intent(in)::n;call get_args(n,rgs);end function rgs
+function dgs(n);real(kind=dp),allocatable::dgs(:);character(len=*),intent(in)::n;call get_args(n,dgs);end function dgs
+function sgs(n,delims)
+character(len=:),allocatable::sgs(:)
+character(len=*),optional,intent(in)::delims
+character(len=*),intent(in)::n
+call get_args(n,sgs,delims)
+end function sgs
+function cgs(n);complex,allocatable::cgs(:);character(len=*),intent(in)::n;call get_args(n,cgs);end function cgs
+function lgs(n);logical,allocatable::lgs(:);character(len=*),intent(in)::n;call get_args(n,lgs);end function lgs
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+function ig()
+integer,allocatable::ig(:)
+integer::i,ierr
+if(allocated(ig))deallocate(ig)
+allocate(ig(size(unnamed)))
+do i=1,size(ig)
+call a2i(unnamed(i),ig(i),ierr)
+enddo
+end function ig
+!===================================================================================================================================
+function rg()
+real,allocatable::rg(:)
+rg=real(dg())
+end function rg
+!===================================================================================================================================
+function dg()
+real(kind=dp),allocatable::dg(:)
+integer::i
+integer::ierr
+if(allocated(dg))deallocate(dg)
+allocate(dg(size(unnamed)))
+do i=1,size(dg)
+call a2d(unnamed(i),dg(i),ierr)
+enddo
+end function dg
+!===================================================================================================================================
+function lg()
+logical,allocatable::lg(:)
+integer::i
+integer::iichar
+character,allocatable::hold
+if(allocated(lg))deallocate(lg)
+allocate(lg(size(unnamed)))
+do i=1,size(lg)
+hold=trim(upper(adjustl(unnamed(i))))
+if(hold(1:1)=='.')then! looking for fortran logical syntax .STRING.
+iichar=2
+else
+iichar=1
+endif
+ select case(hold(iichar:iichar))! check word to see if true or false
+case('T','Y',' ');lg(i)=.true.! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
+case('F','N');lg(i)=.false.! assume this is false or no
+case default
+call journal("*lg* bad logical expression for element",i,'=',hold)
+end select
+ enddo
+end function lg
+!===================================================================================================================================
+function cg()
+complex,allocatable::cg(:)
+integer::i,ierr
+real(kind=dp)::rc,ic
+if(allocated(cg))deallocate(cg)
+allocate(cg(size(unnamed)))
+do i=1,size(cg),2
+call a2d(unnamed(i),rc,ierr)
+call a2d(unnamed(i+1),ic,ierr)
+cg(i)=cmplx(rc,ic,kind=sp)
+enddo
+end function cg
+!===================================================================================================================================
+! Does not work with gcc 5.3
+!function sg()
+!character(len=:),allocatable :: sg(:)
+! sg=unnamed
+!end function sg
+
+!===================================================================================================================================
+function sg()
+character(len=:),allocatable::sg(:)
+if(allocated(sg))deallocate(sg)
+allocate(sg,source=unnamed)
+end function sg
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+subroutine mystop(sig,msg)
+! negative signal means always stop program
+! else do not stop and set G_STOP_MESSAGE if G_QUIET is true
+! or
+! print message and stop if G_QUIET is false
+! the MSG is NOT for displaying except for internal errors when the program will be stopped.
+! It is for returning a value when the stop is being ignored
+!
+integer,intent(in)::sig
+character(len=*),intent(in),optional::msg
+if(sig<0)then
+ if(present(msg))call journal(msg)
+stop 1
+elseif(.not.G_QUIET)then
+ stop
+ else
+ if(present(msg))then
+G_STOP_MESSAGE=msg
+else
+G_STOP_MESSAGE=''
+endif
+G_STOP=sig
+endif
+end subroutine mystop
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+function atleast(line,length,pattern)result(strout)
+
+! ident_30="@(#) M_strings atleast(3f) return string padded to at least specified length"
+
+character(len=*),intent(in)::line
+integer,intent(in)::length
+character(len=*),intent(in),optional::pattern
+character(len=max(length,len(trim(line))))::strout
+if(present(pattern))then
+strout=line//repeat(pattern,len(strout)/len(pattern)+1)
+else
+strout=line
+endif
+end function atleast
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
+!===================================================================================================================================
+subroutine locate_key(value,place)
+
+! ident_31="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed"
+
+character(len=*),intent(in)::value
+integer,intent(out)::place
+integer::ii
+character(len=:),allocatable::value_local
+
+if(G_UNDERDASH)then
+value_local=trim(replace_str(value,'-','_'))
+else
+value_local=trim(value)
+endif
+ if(G_NOSEPARATOR)then
+value_local=replace_str(value_local,'-','')
+value_local=replace_str(value_local,'_','')
+endif
+
+ if(G_IGNORECASE.and.len_trim(value_local)>1)value_local=lower(value_local)
+
+if(len(value_local)==1)then
+!x!ii=findloc(shorts,value_local,dim=1)
+ii=maxloc([0,merge(1,0,shorts==value_local)],dim=1)
+if(ii>1)then
+place=ii-1
+else
+ call locate_(keywords,value_local,place)
+endif
+ else
+ call locate_(keywords,value_local,place)
+endif
+end subroutine locate_key
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+!>
+!!##NAME
+!! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine set_mode(key,mode)
+!!
+!! character(len=*),intent(in) :: key
+!! logical,intent(in),optional :: mode
+!!
+!!##DESCRIPTION
+!! Allow optional behaviors.
+!!
+!!##OPTIONS
+!! KEY name of option
+!!
+!! The following values are allowed:
+!!
+!! o response_file - enable use of response file
+!!
+!! o ignorecase - ignore case in long key names. So the user
+!! does not have to remember if the option is --IgnoreCase
+!! or --ignorecase or --ignoreCase!!
-!!##DESCRIPTION
-!!
-!! Remove a value from an allocatable array at the specified index.
-!! The array is assumed to be sorted in descending order. It may be of
-!! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER.
-!!
-!!##OPTIONS
+!! o underdash - treat dash in keyword as an underscore.
+!! So the user should not have to remember if the option is
+!! --ignore_case or --ignore-case.
+!!
+!! o strict - allow Boolean keys to be bundled, but requires
+!! a single dash prefix be used for short key names and
+!! long names must be prefixed with two dashes.!!
-!! list is the list array.
-!! PLACE is the subscript for the entry that should be removed
+!! o lastonly - when multiple keywords occur keep the rightmost
+!! value specified instead of appending the values together.!!
-!!##EXAMPLES
-!!
-!!
-!! Sample program
-!!
-!! program demo_remove
-!! use M_sort, only : sort_shell
-!! use M_CLI2, only : locate_, remove_
-!! implicit none
-!! character(len=:),allocatable :: arr(:)
-!! integer :: i
-!! integer :: end
-!!
-!! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ]
-!! ! make sure sorted in descending order
-!! call sort_shell(arr,order='d')
-!!
-!! end=size(arr)
-!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
-!! call remove_(arr,1)
-!! end=size(arr)
-!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
-!! call remove_(arr,4)
-!! end=size(arr)
-!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
-!!
-!! end program demo_remove
-!!
-!! Results:
-!!
-!! Expected output
-!!
-!! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,,
-!! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,,
-!! SIZE=7 bb,b,b,aaa,ZZZ,Z,,
-!!
-!!##AUTHOR
-!! 1989,2017 John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine remove_c(list,place)
-
-! ident_30="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position"
-
-character(len=:),allocatable::list(:)
-integer,intent(in)::place
-integer::ii,end
- if(.not.allocated(list))then
-list=[character(len=2)::]
-endif
-ii=len(list)
-end=size(list)
-if(place<=0.or.place>end)then! index out of bounds of array
-elseif(place==end)then! remove from array
-list=[character(len=ii)::list(:place-1)]
-else
-list=[character(len=ii)::list(:place-1),list(place+1:)]
-endif
-end subroutine remove_c
-subroutine remove_l(list,place)
-
-! ident_31="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position"
-
-logical,allocatable::list(:)
-integer,intent(in)::place
-integer::end
-
- if(.not.allocated(list))then
-list=[logical::]
-endif
- end=size(list)
-if(place<=0.or.place>end)then! index out of bounds of array
-elseif(place==end)then! remove from array
-list=[list(:place-1)]
-else
-list=[list(:place-1),list(place+1:)]
-endif
-
-end subroutine remove_l
-subroutine remove_i(list,place)
-
-! ident_32="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position"
-integer,allocatable::list(:)
-integer,intent(in)::place
-integer::end
-
- if(.not.allocated(list))then
-list=[integer::]
-endif
- end=size(list)
-if(place<=0.or.place>end)then! index out of bounds of array
-elseif(place==end)then! remove from array
-list=[list(:place-1)]
-else
-list=[list(:place-1),list(place+1:)]
-endif
-
-end subroutine remove_i
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! replace_(3f) - [M_CLI2] replace entry in a string array at specified position
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine replace_(list,value,place)
-!!
-!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
-!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:)
-!! integer, intent(out) :: PLACE
-!!
-!!##DESCRIPTION
-!!
-!! replace a value in an allocatable array at the specified index. Unless the
-!! array needs the string length to increase this is merely an assign of a value
-!! to an array element.
-!!
-!! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER>
-!! It is assumed to be sorted in descending order without duplicate values.
-!!
-!! The value and list must be of the same type.
-!!
-!!##OPTIONS
-!!
-!! VALUE the value to place in the array
-!! LIST is the array.
-!! PLACE is the subscript that the entry should be placed at
-!!
-!!##EXAMPLES
-!!
-!!
-!! Replace key-value pairs in a dictionary
-!!
-!! program demo_replace
-!! use M_CLI2, only : insert_, locate_, replace_
-!! ! Find if a key is in a list and insert it
-!! ! into the key list and value list if it is not present
-!! ! or replace the associated value if the key existed
-!! implicit none
-!! character(len=20) :: key
-!! character(len=100) :: val
-!! character(len=:),allocatable :: keywords(:)
-!! character(len=:),allocatable :: values(:)
-!! integer :: i
-!! integer :: place
-!! call update('b','value of b')
-!! call update('a','value of a')
-!! call update('c','value of c')
-!! call update('c','value of c again')
-!! call update('d','value of d')
-!! call update('a','value of a again')
-!! ! show array
-!! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords))
-!!
-!! call locate_key('a',place)
-!! if(place > 0)then
-!! write(*,*)'The value of "a" is',trim(values(place))
-!! else
-!! write(*,*)'"a" not found'
-!! endif
-!!
-!! contains
-!! subroutine update(key,val)
-!! character(len=*),intent(in) :: key
-!! character(len=*),intent(in) :: val
-!! integer :: place
-!!
-!! ! find where string is or should be
-!! call locate_key(key,place)
-!! ! if string was not found insert it
-!! if(place < 1)then
-!! call insert_(keywords,key,abs(place))
-!! call insert_(values,val,abs(place))
-!! else ! replace
-!! call replace_(values,val,place)
-!! endif
-!!
-!! end subroutine update
-!! end program demo_replace_
-!!
-!! Expected output
-!!
-!! d==>value of d
-!! c==>value of c again
-!! b==>value of b
-!! a==>value of a again
-!!
-!!##AUTHOR
-!! 1989,2017 John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine replace_c(list,value,place)
-
-! ident_33="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position"
-
-character(len=*),intent(in)::value
-character(len=:),allocatable::list(:)
-character(len=:),allocatable::kludge(:)
-integer,intent(in)::place
-integer::ii
-integer::tlen
-integer::end
- if(.not.allocated(list))then
-list=[character(len=max(len_trim(value),2))::]
-endif
-tlen=len_trim(value)
-end=size(list)
-if(place<0.or.place>end)then
- write(warn,*)'*replace_c* error: index out of range. end=',end,' index=',place
-elseif(len_trim(value)<=len(list))then
-list(place)=value
- else! increase length of variable
-ii=max(tlen,len(list))
-kludge=[character(len=ii)::list]
-list=kludge
-list(place)=value
- endif
-end subroutine replace_c
-subroutine replace_l(list,value,place)
-
-! ident_34="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position"
-
-logical,allocatable::list(:)
-logical,intent(in)::value
-integer,intent(in)::place
-integer::end
- if(.not.allocated(list))then
-list=[logical::]
-endif
- end=size(list)
-if(end==0)then! empty array
-list=[value]
-elseif(place>0.and.place<=end)then
-list(place)=value
- else! put in middle of array
-write(warn,*)'*replace_l* error: index out of range. end=',end,' index=',place
-endif
-end subroutine replace_l
-subroutine replace_i(list,value,place)
-
-! ident_35="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position"
-
-integer,intent(in)::value
-integer,allocatable::list(:)
-integer,intent(in)::place
-integer::end
- if(.not.allocated(list))then
-list=[integer::]
-endif
- end=size(list)
-if(end==0)then! empty array
-list=[value]
-elseif(place>0.and.place<=end)then
-list(place)=value
- else! put in middle of array
-write(warn,*)'*replace_i* error: index out of range. end=',end,' index=',place
-endif
-end subroutine replace_i
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
-!! insert_(3f) - [M_CLI2] insert entry into a string array at specified position
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine insert_(list,value,place)
-!!
-!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
-!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:)
-!! integer,intent(in) :: place
-!!
-!!##DESCRIPTION
-!!
-!! Insert a value into an allocatable array at the specified index.
-!! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION,
-!! REAL, or INTEGER)
-!!
-!!##OPTIONS
-!!
-!! list is the list array. Must be sorted in descending order.
-!! value the value to place in the array
-!! PLACE is the subscript that the entry should be placed at
-!!
-!!##EXAMPLES
-!!
-!!
-!! Find if a string is in a sorted array, and insert the string into
-!! the list if it is not present ...
-!!
-!! program demo_insert
-!! use M_sort, only : sort_shell
-!! use M_CLI2, only : locate_, insert_
-!! implicit none
-!! character(len=:),allocatable :: arr(:)
-!! integer :: i
-!!
-!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ]
-!! ! make sure sorted in descending order
-!! call sort_shell(arr,order='d')
-!! ! add or replace values
-!! call update(arr,'b')
-!! call update(arr,'[')
-!! call update(arr,'c')
-!! call update(arr,'ZZ')
-!! call update(arr,'ZZZ')
-!! call update(arr,'ZZZZ')
-!! call update(arr,'')
-!! call update(arr,'z')
-!!
-!! contains
-!! subroutine update(arr,string)
-!! character(len=:),allocatable :: arr(:)
-!! character(len=*) :: string
-!! integer :: place, end
-!!
-!! end=size(arr)
-!! ! find where string is or should be
-!! call locate_(arr,string,place)
-!! ! if string was not found insert it
-!! if(place < 1)then
-!! call insert_(arr,string,abs(place))
-!! endif
-!! ! show array
-!! end=size(arr)
-!! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
-!!
-!! end subroutine update
-!! end program demo_insert_
-!!
-!! Results:
-!!
-!! array is now SIZE=5 xxx,b,aaa,ZZZ,,
-!! array is now SIZE=6 xxx,b,aaa,[,ZZZ,,
-!! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,,
-!! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,,
-!! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,,
-!! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,,
-!!
-!!##AUTHOR
-!! 1989,2017 John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine insert_c(list,value,place)
-
-! ident_36="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position"
-
-character(len=*),intent(in)::value
-character(len=:),allocatable::list(:)
-character(len=:),allocatable::kludge(:)
-integer,intent(in)::place
-integer::ii
-integer::end
-
- if(.not.allocated(list))then
-list=[character(len=max(len_trim(value),2))::]
-endif
-
-ii=max(len_trim(value),len(list),2)
-end=size(list)
-
-if(end==0)then! empty array
-list=[character(len=ii)::value]
-elseif(place==1)then! put in front of array
-kludge=[character(len=ii)::value,list]
-list=kludge
-elseif(place>end)then! put at end of array
-kludge=[character(len=ii)::list,value]
-list=kludge
-elseif(place>=2.and.place<=end)then! put in middle of array
-kludge=[character(len=ii)::list(:place-1),value,list(place:)]
-list=kludge
-else! index out of range
-write(warn,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value
- endif
-
-end subroutine insert_c
-subroutine insert_l(list,value,place)
-
-! ident_37="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position"
-
-logical,allocatable::list(:)
-logical,intent(in)::value
-integer,intent(in)::place
-integer::end
- if(.not.allocated(list))then
-list=[logical::]
-endif
- end=size(list)
-if(end==0)then! empty array
-list=[value]
-elseif(place==1)then! put in front of array
-list=[value,list]
-elseif(place>end)then! put at end of array
-list=[list,value]
-elseif(place>=2.and.place<=end)then! put in middle of array
-list=[list(:place-1),value,list(place:)]
-else! index out of range
-write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value
- endif
-
-end subroutine insert_l
-subroutine insert_i(list,value,place)
-
-! ident_38="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position"
-
-integer,allocatable::list(:)
-integer,intent(in)::value
-integer,intent(in)::place
-integer::end
- if(.not.allocated(list))then
-list=[integer::]
-endif
- end=size(list)
-if(end==0)then! empty array
-list=[value]
-elseif(place==1)then! put in front of array
-list=[value,list]
-elseif(place>end)then! put at end of array
-list=[list,value]
-elseif(place>=2.and.place<=end)then! put in middle of array
-list=[list(:place-1),value,list(place:)]
-else! index out of range
-write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value
- endif
-
-end subroutine insert_i
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-subroutine many_args(n0,g0,n1,g1,n2,g2,n3,g3,n4,g4,n5,g5,n6,g6,n7,g7,n8,g8,n9,g9,&
-&na,ga,nb,gb,nc,gc,nd,gd,ne,ge,nf,gf,ng,gg,nh,gh,ni,gi,nj,gj)
-
-! ident_39="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)"
-
-character(len=*),intent(in)::n0,n1
-character(len=*),intent(in),optional::n2,n3,n4,n5,n6,n7,n8,n9,na,nb,nc,nd,ne,nf,ng,nh,ni,nj
-class(*),intent(out)::g0,g1
-class(*),intent(out),optional::g2,g3,g4,g5,g6,g7,g8,g9
-class(*),intent(out),optional::ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
-call get_generic(n0,g0)
-call get_generic(n1,g1)
-if(present(n2).and.present(g2))call get_generic(n2,g2)
-if(present(n3).and.present(g3))call get_generic(n3,g3)
-if(present(n4).and.present(g4))call get_generic(n4,g4)
-if(present(n5).and.present(g5))call get_generic(n5,g5)
-if(present(n6).and.present(g6))call get_generic(n6,g6)
-if(present(n7).and.present(g7))call get_generic(n7,g7)
-if(present(n8).and.present(g8))call get_generic(n8,g8)
-if(present(n9).and.present(g9))call get_generic(n9,g9)
-if(present(na).and.present(ga))call get_generic(na,ga)
-if(present(nb).and.present(gb))call get_generic(nb,gb)
-if(present(nc).and.present(gc))call get_generic(nc,gc)
-if(present(nd).and.present(gd))call get_generic(nd,gd)
-if(present(ne).and.present(ge))call get_generic(ne,ge)
-if(present(nf).and.present(gf))call get_generic(nf,gf)
-if(present(ng).and.present(gg))call get_generic(ng,gg)
-if(present(nh).and.present(gh))call get_generic(nh,gh)
-if(present(ni).and.present(gi))call get_generic(ni,gi)
-if(present(nj).and.present(gj))call get_generic(nj,gj)
-contains
-!===================================================================================================================================
-function c(generic)
-class(*),intent(in)::generic
-character(len=:),allocatable::c
-select type(generic)
-type is(character(len=*));c=trim(generic)
-class default
-c='unknown'
-stop'get_many:: parameter name is not character'
-end select
-end function c
-!===================================================================================================================================
-subroutine get_generic(name,generic)
-use,intrinsic::iso_fortran_env,only:real64
-character(len=*),intent(in)::name
-class(*),intent(out)::generic
- select type(generic)
-type is(integer);call get_args(name,generic)
-type is(real);call get_args(name,generic)
-type is(real(kind=real64));call get_args(name,generic)
-type is(logical);call get_args(name,generic)
-!x!type is (character(len=:),allocatable ::); call get_args(name,generic)
-type is(character(len=*));
-call get_args_fixed_length(name,generic)
-type is(complex);call get_args(name,generic)
-class default
-stop'unknown type in *get_generic*'
-end select
-end subroutine get_generic
-!===================================================================================================================================
-end subroutine many_args
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function iget(n);integer::iget;character(len=*),intent(in)::n;call get_args(n,iget);end function iget
-function rget(n);real::rget;character(len=*),intent(in)::n;call get_args(n,rget);end function rget
-function dget(n);real(kind=dp)::dget;character(len=*),intent(in)::n;call get_args(n,dget);end function dget
-function sget(n);character(len=:),allocatable::sget;character(len=*),intent(in)::n;call get_args(n,sget);end function sget
-function cget(n);complex::cget;character(len=*),intent(in)::n;call get_args(n,cget);end function cget
-function lget(n);logical::lget;character(len=*),intent(in)::n;call get_args(n,lget);end function lget
-
-function igs(n);integer,allocatable::igs(:);character(len=*),intent(in)::n;call get_args(n,igs);end function igs
-function rgs(n);real,allocatable::rgs(:);character(len=*),intent(in)::n;call get_args(n,rgs);end function rgs
-function dgs(n);real(kind=dp),allocatable::dgs(:);character(len=*),intent(in)::n;call get_args(n,dgs);end function dgs
-function sgs(n,delims)
-character(len=:),allocatable::sgs(:)
-character(len=*),optional,intent(in)::delims
-character(len=*),intent(in)::n
-call get_args(n,sgs,delims)
-end function sgs
-function cgs(n);complex,allocatable::cgs(:);character(len=*),intent(in)::n;call get_args(n,cgs);end function cgs
-function lgs(n);logical,allocatable::lgs(:);character(len=*),intent(in)::n;call get_args(n,lgs);end function lgs
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-function ig()
-integer,allocatable::ig(:)
-integer::i,ierr
-if(allocated(ig))deallocate(ig)
-allocate(ig(size(unnamed)))
-do i=1,size(ig)
-call a2i(unnamed(i),ig(i),ierr)
-enddo
-end function ig
-!===================================================================================================================================
-function rg()
-real,allocatable::rg(:)
-rg=real(dg())
-end function rg
-!===================================================================================================================================
-function dg()
-real(kind=dp),allocatable::dg(:)
-integer::i
-integer::ierr
-if(allocated(dg))deallocate(dg)
-allocate(dg(size(unnamed)))
-do i=1,size(dg)
-call a2d(unnamed(i),dg(i),ierr)
-enddo
-end function dg
-!===================================================================================================================================
-function lg()
-logical,allocatable::lg(:)
-integer::i
-integer::iichar
-character,allocatable::hold
-if(allocated(lg))deallocate(lg)
-allocate(lg(size(unnamed)))
-do i=1,size(lg)
-hold=trim(upper(adjustl(unnamed(i))))
-if(hold(1:1)=='.')then! looking for fortran logical syntax .STRING.
-iichar=2
-else
-iichar=1
-endif
- select case(hold(iichar:iichar))! check word to see if true or false
-case('T','Y',' ');lg(i)=.true.! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
-case('F','N');lg(i)=.false.! assume this is false or no
-case default
-call journal('sc',"*lg* bad logical expression for element",i,'=',hold)
-end select
- enddo
-end function lg
-!===================================================================================================================================
-function cg()
-complex,allocatable::cg(:)
-integer::i,ierr
-real(kind=dp)::rc,ic
-if(allocated(cg))deallocate(cg)
-allocate(cg(size(unnamed)))
-do i=1,size(cg),2
-call a2d(unnamed(i),rc,ierr)
-call a2d(unnamed(i+1),ic,ierr)
-cg(i)=cmplx(rc,ic,kind=sp)
-enddo
-end function cg
-!===================================================================================================================================
-! Does not work with gcc 5.3
-!function sg()
-!character(len=:),allocatable :: sg(:)
-! sg=unnamed
-!end function sg
-
-function sg()
-character(len=:),allocatable::sg(:)
-if(allocated(sg))deallocate(sg)
-allocate(sg,source=unnamed)
-end function sg
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-subroutine mystop(sig,msg)
-! negative signal means always stop program
-! else do not stop and set G_STOP_MESSAGE if G_QUIET is true
-! or
-! print message and stop if G_QUIET is false
-! the MSG is NOT for displaying except for internal errors when the program will be stopped.
-! It is for returning a value when the stop is being ignored
-!
-integer,intent(in)::sig
-character(len=*),intent(in),optional::msg
-!x!write(*,*)'MYSTOP:',sig,trim(msg)
-if(sig<0)then
- if(present(msg))call journal('sc',msg)
-!x!stop abs(sig)
-stop 1
-elseif(.not.G_QUIET)then
- stop
- else
- if(present(msg))then
-G_STOP_MESSAGE=msg
-else
-G_STOP_MESSAGE=''
-endif
-G_STOP=sig
-!x!write(*,*)'G_STOP:',g_stop,trim(msg)
-endif
-end subroutine mystop
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-function atleast(line,length,pattern)result(strout)
-
-! ident_40="@(#) M_strings atleast(3f) return string padded to at least specified length"
-
-character(len=*),intent(in)::line
-integer,intent(in)::length
-character(len=*),intent(in),optional::pattern
-character(len=max(length,len(trim(line))))::strout
-if(present(pattern))then
-strout=line//repeat(pattern,len(strout)/len(pattern)+1)
-else
-strout=line
-endif
-end function atleast
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-subroutine locate_key(value,place)
-
-! ident_41="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed"
-
-character(len=*),intent(in)::value
-integer,intent(out)::place
-integer::ii
-character(len=:),allocatable::value_local
-
-if(G_UNDERDASH)then
-value_local=trim(replace_str(value,'-','_'))
-else
-value_local=trim(value)
-endif
-
- if(G_IGNORECASE.and.len(value_local)>1)value_local=lower(value_local)
-
-if(len(value_local)==1)then
-!x!ii=findloc(shorts,value_local,dim=1)
-ii=maxloc([0,merge(1,0,shorts==value_local)],dim=1)
-if(ii>1)then
-place=ii-1
-else
- call locate_(keywords,value_local,place)
-endif
- else
- call locate_(keywords,value_local,place)
-endif
-end subroutine locate_key
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine set_mode(key,mode)
-!!
-!! character(len=*),intent(in) :: key
-!! logical,intent(in),optional :: mode
-!!
-!!##DESCRIPTION
-!! Allow optional behaviors.
-!!
-!!##OPTIONS
-!! KEY name of option
-!! o response_file - enable use of response file
-!! o ignorecase - ignore case in long key names
-!! o underdash - treat dash in keyname as an underscore
-!! o strict - allow boolean keys to be bundled, but requires
-!! a single dash prefix be used for short key names and
-!! long names to be prefixed with two dashes.
-!!
-!! MODE set to .true. to activate the optional mode.
-!! Set to .false. to deactivate the mode.
-!! It is .true. by default.
-!!
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_set_mode
-!! use M_CLI2, only : set_args, lget, set_mode
-!! implicit none
-!! character(len=*),parameter :: all='(*(g0))'
-!! !
-!! ! enable use of response files
-!! call set_mode('response_file')
-!! !
-!! ! Any dash in a keyname is treated as an underscore
-!! call set_mode('underdash')
-!! !
-!! ! The case of long keynames are ignored.
-!! ! Values and short names remain case-sensitive
-!! call set_mode('ignorecase')
-!! !
-!! ! short single-character boolean keys may be bundled
-!! ! but it is required that a single dash is used for
-!! ! short keys and a double dash for long keynames.
-!! call set_mode('strict')
-!! !
-!! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
-!! !
-!! print all,'--switch_X or -X ... ',lget('switch_X')
-!! print all,'--switch_Y or -Y ... ',lget('switch_Y')
-!! print all,'--ox or -O ... ',lget('ox')
-!! print all,'-o ... ',lget('o')
-!! print all,'-x ... ',lget('x')
-!! print all,'-t ... ',lget('t')
-!! end program demo_set_mode
-!!
-!!##AUTHOR
-!! John S. Urban, 2019
-!!##LICENSE
-!! Public Domain
-!===================================================================================================================================
-elemental impure subroutine set_mode(key,mode)
-character(len=*),intent(in)::key
-logical,intent(in),optional::mode
-logical::local_mode
-if(present(mode))then
-local_mode=mode
-else
-local_mode=.true.
-endif
- select case(lower(key))
-case('response_file','response file');CLI_RESPONSE_FILE=local_mode
-case('debug');G_DEBUG=local_mode
-case('ignorecase');G_IGNORECASE=local_mode
-case('underdash');G_UNDERDASH=local_mode
-case('strict');G_STRICT=local_mode
-case default
-call journal('sc','set_mode* unknown key name ',key)
-end select
-end subroutine set_mode
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-end module M_CLI2
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
+!! MODE set to .true. to activate the optional mode.
+!! Set to .false. to deactivate the mode.
+!! It is .true. by default.
+!!
+!!##EXAMPLE
+!!
+!! Sample program:
+!!
+!! program demo_set_mode
+!! use M_CLI2, only : set_args, lget, set_mode
+!! implicit none
+!! character(len=*),parameter :: all='(*(g0))'
+!! !
+!! ! enable use of response files
+!! call set_mode('response_file')
+!! !
+!! ! Any dash in a keyword is treated as an underscore
+!! call set_mode('underdash')
+!! !
+!! ! The case of long keywords are ignored.
+!! ! Values and short names remain case-sensitive
+!! call set_mode('ignorecase')
+!! !
+!! ! short single-character boolean keys may be bundled
+!! ! but it is required that a single dash is used for
+!! ! short keys and a double dash for long keywords.
+!! call set_mode('strict')
+!! !
+!! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
+!! !
+!! print all,'--switch_X or -X ... ',lget('switch_X')
+!! print all,'--switch_Y or -Y ... ',lget('switch_Y')
+!! print all,'--ox or -O ... ',lget('ox')
+!! print all,'-o ... ',lget('o')
+!! print all,'-x ... ',lget('x')
+!! print all,'-t ... ',lget('t')
+!! end program demo_set_mode
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
+!===================================================================================================================================
+elemental impure subroutine set_mode(key,mode)
+character(len=*),intent(in)::key
+logical,intent(in),optional::mode
+logical::local_mode
+
+if(present(mode))then
+local_mode=mode
+else
+local_mode=.true.
+endif
+
+ select case(lower(key))
+case('response_file','response file');CLI_RESPONSE_FILE=local_mode
+case('debug');G_DEBUG=local_mode
+case('ignorecase');G_IGNORECASE=local_mode
+case('underdash');G_UNDERDASH=local_mode
+case('noseparator');G_NOSEPARATOR=local_mode
+case('strict');G_STRICT=local_mode
+case('lastonly');G_APPEND=.not.local_mode
+case default
+call journal('*set_mode* unknown key name ',key)
+end select
+
+ if(G_DEBUG)write(*,gen)'<DEBUG>EXPAND_RESPONSE:END'
+
+end subroutine set_mode
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
+end module M_CLI2
+!===================================================================================================================================
+!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
+!===================================================================================================================================
@@ -6529,7 +5836,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/manually_test_bundling.f90.html b/docs/fpm-ford/sourcefile/manually_test_bundling.f90.html
index 681bc63c..7e38a9a9 100644
--- a/docs/fpm-ford/sourcefile/manually_test_bundling.f90.html
+++ b/docs/fpm-ford/sourcefile/manually_test_bundling.f90.html
@@ -246,7 +246,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/test_ignorecase.f90.html b/docs/fpm-ford/sourcefile/test_ignorecase.f90.html
index 46f6a83c..d1de3a67 100644
--- a/docs/fpm-ford/sourcefile/test_ignorecase.f90.html
+++ b/docs/fpm-ford/sourcefile/test_ignorecase.f90.html
@@ -90,7 +90,7 @@
test_ignorecase.f90
54 statements
+ title=" 1.5% of total for source files.">53 statements
@@ -214,58 +214,57 @@
Source Code
use M_CLI2,only:set_args,sget,igets,rgets,dgets,lget,set_modeimplicit nonecharacter(len=*),parameter::it='(1x,*(g0,1x))'
-logical,parameter::T=.true.,F=.false.
-character(len=:),allocatable::whichone
-character(len=:),allocatable::arr(:)
-call set_mode('ignorecase')
-
-call set_args(' --type run -a "a AA a" -b "B bb B" -A AAA -B BBB --longa:O " OoO " --longb:X "xXx"')
-whichone=sget('type')
-arr=[character(len=10)::sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X')]
-select case(whichone)
-case('one');call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
-case('two');call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
-case('three');call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
-case('four');call testit(whichone,all([character(len=10)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
-case('five');call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB',&
-&'a b c d e f g h i','xXx','a b c d e f g h i','xXx']==arr))
-case('six');!call testit(whichone, all(arr))
-case('run')
-print*,'test_ignorecase: ignorecase mode'
-call runit('--type one ')
-call runit('--type two -a a -b b -A A -B B -longa longa -longb longb -O O -X X ')
-call runit('--type three -a a -b b -A A -B B -LONGA longa -LONGB longb -O O -X X')
-call runit('--type four -a a -b b -a A -b B -A "SET A" -B "SET B"')
-call runit('--type five --LongA "a b c" -longa "d e f" -longA "g h i"')
-! call runit('--type six -ox -t --ox --xo --longa --longb')
-case default
-print it,'unknown type'
-end select
-contains
-
-subroutine testit(string,test)
-character(len=*),intent(in)::string
-logical,intent(in)::test
-
-write(*,it,advance='no')arr
-if(test)then
- print it,':ignorecase:',string,'passed'
-else
- print it,':ignorecase:',string,'failed'
-stop 1
-endif
-
-end subroutine testit
-
-subroutine runit(string)
-character(len=*),intent(in)::string
-character(len=4096)::cmd
-call get_command_argument(0,cmd)
-write(stdout,*)'RUN:',trim(cmd)//' '//string
-call execute_command_line(trim(cmd)//' '//string)
-end subroutine runit
-
-end program test_ignorecase
+character(len=:),allocatable::whichone
+character(len=:),allocatable::arr(:)
+call set_mode('ignorecase')
+
+call set_args(' --type run -a "a AA a" -b "B bb B" -A AAA -B BBB --longa:O " OoO " --longb:X "xXx"')
+whichone=sget('type')
+arr=[character(len=17)::sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X')]
+select case(whichone)
+case('one');call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
+case('two');call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+case('three');call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+case('four');call testit(whichone,all([character(len=17)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
+case('five');call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB',&
+&'a b c d e f g h i','xXx','a b c d e f g h i','xXx']==arr))
+case('six');!call testit(whichone, all(arr))
+case('run')
+print*,'test_ignorecase: ignorecase mode'
+call runit('--type one ')
+call runit('--type two -a a -b b -A A -B B -longa longa -longb longb -O O -X X ')
+call runit('--type three -a a -b b -A A -B B -LONGA longa -LONGB longb -O O -X X')
+call runit('--type four -a a -b b -a A -b B -A "SET A" -B "SET B"')
+call runit('--type five --LongA "a b c" -longa "d e f" -longA "g h i"')
+! call runit('--type six -ox -t --ox --xo --longa --longb')
+case default
+print it,'unknown type'
+end select
+contains
+
+subroutine testit(string,test)
+character(len=*),intent(in)::string
+logical,intent(in)::test
+
+write(*,it,advance='no')arr
+if(test)then
+ print it,':ignorecase:',string,'passed'
+else
+ print it,':ignorecase:',string,'failed'
+stop 1
+endif
+
+end subroutine testit
+
+subroutine runit(string)
+character(len=*),intent(in)::string
+character(len=4096)::cmd
+call get_command_argument(0,cmd)
+write(stdout,*)'RUN:',trim(cmd)//' '//string
+call execute_command_line(trim(cmd)//' '//string)
+end subroutine runit
+
+end program test_ignorecase
@@ -284,7 +283,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 01:24
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/test_lastonly.f90.html b/docs/fpm-ford/sourcefile/test_lastonly.f90.html
index 2f7bb1ea..1048ae93 100644
--- a/docs/fpm-ford/sourcefile/test_lastonly.f90.html
+++ b/docs/fpm-ford/sourcefile/test_lastonly.f90.html
@@ -289,7 +289,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/test_strict.f90.html b/docs/fpm-ford/sourcefile/test_strict.f90.html
index fb54e777..9936b58d 100644
--- a/docs/fpm-ford/sourcefile/test_strict.f90.html
+++ b/docs/fpm-ford/sourcefile/test_strict.f90.html
@@ -282,7 +282,7 @@
Source Code
Documentation generated by
FORD
- on 2023-02-06 00:31
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/sourcefile/test_syntax.f90.html b/docs/fpm-ford/sourcefile/test_syntax.f90.html
index e3f2face..3fe31f46 100644
--- a/docs/fpm-ford/sourcefile/test_syntax.f90.html
+++ b/docs/fpm-ford/sourcefile/test_syntax.f90.html
@@ -90,7 +90,7 @@
test_syntax.f90
50 statements
+ title=" 1.4% of total for source files.">49 statements
Documentation generated by
FORD
- on 2023-02-08 04:39
+ on 2023-02-10 18:53
diff --git a/docs/fpm-ford/src/M_CLI2.F90 b/docs/fpm-ford/src/M_CLI2.F90
index b084a022..9e6be81e 100755
--- a/docs/fpm-ford/src/M_CLI2.F90
+++ b/docs/fpm-ford/src/M_CLI2.F90
@@ -2,7 +2,7 @@
!VERSION 2.0 20200802
!VERSION 3.0 20201021 LONG:SHORT syntax
!VERSION 3.1 20201115 LONG:SHORT:: syntax
-!VERSION 3.2 20230203 set_mode()
+!VERSION 3.2 20230205 set_mode()
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
@@ -15,38 +15,52 @@
!!
!! Available procedures and variables:
!!
+!! ! basic procedures
!! use M_CLI2, only : set_args, get_args, specified, set_mode
-!! use M_CLI2, only : unnamed, remaining, args
-!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
!! ! convenience functions
!! use M_CLI2, only : dget, iget, lget, rget, sget, cget
!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets
+!! ! variables
+!! use M_CLI2, only : unnamed, remaining, args
+!! ! working with non-allocatable strings and arrays
+!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size
+!! ! special function for creating subcommands
+!! use M_CLI2, only : get_subcommand(3f)
!!
!!##DESCRIPTION
-!! Allow for command line parsing much like standard Unix command line
-!! parsing using a simple prototype.
+!! The M_CLI2 module cracks a Unix-style command line.
!!
!! Typically one call to SET_ARGS(3f) is made to define the command
!! arguments, set default values and parse the command line. Then a call
-!! is made to the convenience commands based on GET_ARGS(3f) for each
+!! is made to the convenience procedures or GET_ARGS(3f) proper for each
!! command keyword to obtain the argument values.
!!
-!! The documentation for SET_ARGS(3f) and GET_ARGS(3f) provides further
-!! details.
+!! Detailed descriptions of each procedure and example programs are
+!! included.
!!
!!##EXAMPLE
!!
!!
-!! Sample typical minimal usage
+!! Sample minimal program which may be called in various ways:
+!!
+!! mimimal -x 100.3 -y 3.0e4
+!! mimimal --xvalue=300 --debug
+!! mimimal --yvalue 400
+!! mimimal -x 10 file1 file2 file3
+!!
+!! Program example:
!!
!! program minimal
-!! use M_CLI2, only : set_args, lget, rget, filenames=>unnamed
+!! use M_CLI2, only : set_args, lget, rget, sgets
!! implicit none
!! real :: x, y
!! integer :: i
-!! call set_args(' -y 0.0 -x 0.0 --debug F')
-!! x=rget('x')
-!! y=rget('y')
+!! character(len=:),allocatable :: filenames(:)
+!! ! define and crack command line
+!! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F')
+!! ! get values
+!! x=rget('xvalue')
+!! y=rget('yvalue')
!! if(lget('debug'))then
!! write(*,*)'X=',x
!! write(*,*)'Y=',y
@@ -54,6 +68,7 @@
!! else
!! write(*,*)atan2(x=x,y=y)
!! endif
+!! filenames=sgets() ! sget with no name gets "unnamed" values
!! if(size(filenames) > 0)then
!! write(*,'(g0)')'filenames:'
!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
@@ -69,22 +84,25 @@
!! implicit none
!! integer :: i
!! integer,parameter :: dp=kind(0.0d0)
-!! !
-!! ! DEFINE ARGS
+!! !
+!! ! Define ARGS
!! real :: x, y, z
-!! real(kind=dp),allocatable :: point(:)
!! logical :: l, lbig
+!! character(len=40) :: label ! FIXED LENGTH
+!! real(kind=dp),allocatable :: point(:)
!! logical,allocatable :: logicals(:)
!! character(len=:),allocatable :: title ! VARIABLE LENGTH
-!! character(len=40) :: label ! FIXED LENGTH
!! real :: p(3) ! FIXED SIZE
!! logical :: logi(3) ! FIXED SIZE
-!! !
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o set a value for all keywords.
-!! ! o double-quote strings
-!! ! o set all logical values to F or T.
-!! ! o value delimiter is comma, colon, or space
+!! !
+!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+!! ! o set a value for all keywords.
+!! ! o double-quote strings, strings must be at least one space
+!! ! because adjacent double-quotes designate a double-quote
+!! ! in the value.
+!! ! o set all logical values to F
+!! ! o numeric values support an "e" or "E" exponent
+!! ! o for lists delimit with a comma, colon, or space
!! call set_args(' &
!! & -x 1 -y 2 -z 3 &
!! & -p -1 -2 -3 &
@@ -95,26 +113,34 @@
!! & --label " " &
!! ! note space between quotes is required
!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args('x',x) ! SCALARS
-!! call get_args('y',y)
-!! call get_args('z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! call get_args('title',title) ! ALLOCATABLE STRING
-!! call get_args('point',point) ! ALLOCATABLE ARRAYS
+!! ! Assign values to elements using G_ARGS(3f).
+!! ! non-allocatable scalars can be done up to twenty per call
+!! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig)
+!! ! As a convenience multiple pairs of keywords and variables may be
+!! ! specified if and only if all the values are scalars and the CHARACTER
+!! ! variables are fixed-length or pre-allocated.
+!! !
+!! ! After SET_ARGS(3f) has parsed the command line
+!! ! GET_ARGS(3f) retrieves the value of keywords accept for
+!! ! two special cases. For fixed-length CHARACTER variables
+!! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! ! GET_ARGS_FIXED_SIZE(3f).
+!! !
+!! ! allocatables should be done one at a time
+!! call get_args('title',title) ! allocatable string
+!! call get_args('point',point) ! allocatable arrays
!! call get_args('logicals',logicals)
-!! !
-!! ! for NON-ALLOCATABLE VARIABLES
+!! !
+!! ! less commonly ...
!!
-!! ! for non-allocatable string
+!! ! for fixed-length strings
!! call get_args_fixed_length('label',label)
!!
-!! ! for non-allocatable arrays
+!! ! for non-allocatable arrays
!! call get_args_fixed_size('p',p)
!! call get_args_fixed_size('logi',logi)
-!! !
-!! ! USE VALUES
+!! !
+!! ! all done parsing, use values
!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z
!! write(*,*)'p=',p
!! write(*,*)'point=',point
@@ -124,34 +150,39 @@
!! write(*,*)'L=',lbig
!! write(*,*)'logicals=',logicals
!! write(*,*)'logi=',logi
-!! !
-!! ! unnamed strings
-!! !
+!! !
+!! ! unnamed strings
+!! !
!! if(size(filenames) > 0)then
!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
!! endif
-!! !
+!! !
!! end program demo_M_CLI2
!!
!!##AUTHOR
!! John S. Urban, 2019
!!##LICENSE
!! Public Domain
+!!##SEE ALSO
+!! + get_args(3f)
+!! + get_args_fixed_size(3f)
+!! + get_args_fixed_length(3f)
+!! + get_subcommand(3f)
+!! + set_mode(3f)
+!! + specified(3f)
+!!
+!! Note that the convenience routines are described under get_args(3f):
+!! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),
+!! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f)
!===================================================================================================================================
module M_CLI2
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT, warn=>OUTPUT_UNIT
-
-! copied to M_CLI2 for a stand-alone version
-!use M_strings, only : upper, lower, quote, replace_str=>replace, unquote, split, string_to_value, atleast
-!use M_list, only : insert, locate, remove, replace
-!use M_args, only : longest_command_argument
-!use M_journal, only : journal
-
implicit none
+private
+
integer,parameter,private :: dp=kind(0.0d0)
integer,parameter,private :: sp=kind(0.0)
-private
-!===================================================================================================================================
+
character(len=*),parameter :: gen='(*(g0))'
character(len=:),allocatable,public :: unnamed(:)
character(len=:),allocatable,public :: args(:)
@@ -168,13 +199,6 @@ module M_CLI2
public :: dget, iget, lget, rget, sget, cget
public :: dgets, igets, lgets, rgets, sgets, cgets
-private :: check_commandline
-private :: wipe_dictionary
-private :: prototype_to_dictionary
-private :: update
-private :: prototype_and_cmd_args_to_nlist
-private :: get
-
type option
character(:),allocatable :: shortname
character(:),allocatable :: longname
@@ -183,7 +207,7 @@ module M_CLI2
logical :: present_in
logical :: mandatory
end type option
-!===================================================================================================================================
+
character(len=:),allocatable,save :: keywords(:)
character(len=:),allocatable,save :: shorts(:)
character(len=:),allocatable,save :: values(:)
@@ -193,8 +217,10 @@ module M_CLI2
logical,save :: G_DEBUG=.false.
logical,save :: G_UNDERDASH=.false.
-logical,save :: G_IGNORECASE=.false.
+logical,save :: G_NOSEPARATOR=.false.
+logical,save :: G_IGNORECASE=.false. ! ignore case of long keywords
logical,save :: G_STRICT=.false. ! strict short and long rules or allow -longname and --shortname
+logical,save :: G_APPEND=.true. ! whether to append or replace when duplicate keywords found
logical,save :: G_keyword_single_letter=.true.
character(len=:),allocatable,save :: G_passed_in
@@ -205,16 +231,14 @@ module M_CLI2
integer,save :: G_STOP
logical,save :: G_QUIET
character(len=:),allocatable,save :: G_PREFIX
-!----------------------------------------------
+
! try out response files
! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via "set_mode('response_file')
logical,save,public :: CLI_RESPONSE_FILE=.false. ! allow @name abbreviations
-logical,save :: G_APPEND ! whether to append or replace when duplicate keywords found
logical,save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand()
logical,save :: G_RESPONSE ! allow @name abbreviations
character(len=:),allocatable,save :: G_RESPONSE_IGNORED
-!----------------------------------------------
-!===================================================================================================================================
+
! return allocatable arrays
interface get_args; module procedure get_anyarray_d; end interface ! any size array
interface get_args; module procedure get_anyarray_i; end interface ! any size array
@@ -230,9 +254,10 @@ module M_CLI2
interface get_args; module procedure get_scalar_complex; end interface
interface get_args; module procedure get_scalar_logical; end interface
interface get_args; module procedure get_scalar_anylength_c; end interface ! any length
+
! multiple scalars
interface get_args; module procedure many_args; end interface
-!==================================================================================================================================
+
! return non-allocatable arrays
! said in conflict with get_args_*. Using class to get around that.
! that did not work either. Adding size parameter as optional parameter works; but using a different name
@@ -245,39 +270,21 @@ module M_CLI2
interface get_args_fixed_length; module procedure get_args_fixed_length_a_array; end interface ! fixed length any size array
interface get_args_fixed_length; module procedure get_args_fixed_length_scalar_c; end interface ! fixed length
-!===================================================================================================================================
-!intrinsic findloc
-!===================================================================================================================================
-
-! ident_1="@(#) M_CLI2 str(3f) {msg_scalar msg_one}"
-
-private str
-interface str
- module procedure msg_scalar, msg_one
-end interface str
-!===================================================================================================================================
-
-private locate_ ! [M_CLI2] find PLACE in sorted character array where value can be found or should be placed
- private locate_c
-private insert_ ! [M_CLI2] insert entry into a sorted allocatable array at specified position
- private insert_c
- private insert_i
- private insert_l
-private replace_ ! [M_CLI2] replace entry by index from a sorted allocatable array if it is present
- private replace_c
- private replace_i
- private replace_l
-private remove_ ! [M_CLI2] delete entry by index from a sorted allocatable array if it is present
- private remove_c
- private remove_i
- private remove_l
! Generic subroutine inserts element into allocatable array at specified position
+
+! find PLACE in sorted character array where value can be found or should be placed
interface locate_; module procedure locate_c ; end interface
+
+! insert entry into a sorted allocatable array at specified position
interface insert_; module procedure insert_c, insert_i, insert_l ; end interface
+
+! replace entry by index from a sorted allocatable array if it is present
interface replace_; module procedure replace_c, replace_i, replace_l ; end interface
+
+! delete entry by index from a sorted allocatable array if it is present
interface remove_; module procedure remove_c, remove_i, remove_l ; end interface
-!-----------------------------------------------------------------------------------------------------------------------------------
+
! convenience functions
interface cgets;module procedure cgs, cg;end interface
interface dgets;module procedure dgs, dg;end interface
@@ -285,7 +292,7 @@ module M_CLI2
interface lgets;module procedure lgs, lg;end interface
interface rgets;module procedure rgs, rg;end interface
interface sgets;module procedure sgs, sg;end interface
-!-----------------------------------------------------------------------------------------------------------------------------------
+
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
@@ -364,14 +371,13 @@ subroutine check_commandline(help_text,version_text)
integer :: iback
if(get('usage') == 'T')then
call print_dictionary('USAGE:')
- !x!call default_help()
call mystop(32)
return
endif
if(present(help_text))then
if(get('help') == 'T')then
do i=1,size(help_text)
- call journal('sc',help_text(i))
+ call journal(help_text(i))
enddo
call mystop(1,'displayed help text')
return
@@ -392,9 +398,9 @@ subroutine check_commandline(help_text,version_text)
endif
endif
do i=1,size(version_text)
- !xINTEL BUG*!call journal('sc',version_text(i)(istart:len_trim(version_text(i))-iback))
+ !xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback))
line=version_text(i)(istart:len_trim(version_text(i))-iback)
- call journal('sc',line)
+ call journal(line)
enddo
call mystop(3,'displayed version text')
return
@@ -404,7 +410,7 @@ subroutine check_commandline(help_text,version_text)
if(G_QUIET)then
G_STOP_MESSAGE = 'no version text'
else
- call journal('sc','*check_commandline* no version text')
+ call journal('*check_commandline* no version text')
endif
call mystop(4,'displayed default version text')
return
@@ -418,9 +424,9 @@ subroutine default_help()
allocate(character(len=ilength) :: cmd_name)
call get_command_argument(number=0,value=cmd_name)
G_passed_in=G_passed_in//repeat(' ',len(G_passed_in))
- call substitute(G_passed_in,' --',NEW_LINE('A')//' --')
+ G_passed_in=replace_str(G_passed_in, ' --', NEW_LINE('A')//' --')
if(.not.G_QUIET)then
- call journal('sc',cmd_name,G_passed_in) ! no help text, echo command and default options
+ call journal(cmd_name,G_passed_in) ! no help text, echo command and default options
endif
deallocate(cmd_name)
end subroutine default_help
@@ -435,61 +441,62 @@ end subroutine check_commandline
!!
!!##SYNOPSIS
!!
-!! subroutine set_args(definition,help_text,version_text,ierr,errmsg)
+!! subroutine set_args(prototype,help_text,version_text,ierr,errmsg)
!!
-!! character(len=*),intent(in),optional :: definition
+!! character(len=*),intent(in),optional :: prototype
!! character(len=*),intent(in),optional :: help_text(:)
!! character(len=*),intent(in),optional :: version_text(:)
!! integer,intent(out),optional :: ierr
!! character(len=:),intent(out),allocatable,optional :: errmsg
!!##DESCRIPTION
!!
-!! SET_ARGS(3f) requires a unix-like command prototype for defining
-!! arguments and default command-line options. Argument values are then
-!! read using GET_ARGS(3f).
+!! SET_ARGS(3f) requires a unix-like command prototype which defines
+!! the command-line options and their default values. When the program
+!! is executed this and the command-line options are applied and the
+!! resulting values are placed in an internal table for retrieval via
+!! GET_ARGS(3f).
!!
-!! The --help and --version options require the optional
-!! help_text and version_text values to be provided.
+!! The built-in --help and --version options require optional help_text
+!! and version_text values to be provided to be particularly useful.
!!
!!##OPTIONS
!!
-!! DEFINITION composed of all command arguments concatenated
+!! PROTOTYPE composed of all command arguments concatenated
!! into a Unix-like command prototype string. For
!! example:
!!
!! call set_args('-L F --ints 1,2,3 --title "my title" -R 10.3')
!!
-!! DEFINITION is pre-defined to act as if started with
-!! the reserved options '--verbose F --usage F --help
-!! F --version F'. The --usage option is processed when
-!! the set_args(3f) routine is called. The same is true
-!! for --help and --version if the optional help_text
-!! and version_text options are provided.
+!! The following options are predefined for all commands:
+!! '--verbose F --usage F --help F --version F'.
!!
!! see "DEFINING THE PROTOTYPE" in the next section for
!! further details.
!!
-!! HELP_TEXT if present, will be displayed if program is called with
-!! --help switch, and then the program will terminate. If
-!! not supplied, the command line initialization string
-!! will be shown when --help is used on the commandline.
+!! HELP_TEXT if present, will be displayed when the program is called with
+!! a --help switch, and then the program will terminate. If
+!! help text is not supplied the command line initialization
+!! string will be echoed.
!!
-!! VERSION_TEXT if present, will be displayed if program is called with
-!! --version switch, and then the program will terminate.
-!! IERR if present a non-zero option is returned when an
-!! error occurs instead of program execution being
-!! terminated
-!! ERRMSG a description of the error if ierr is present
+!! VERSION_TEXT if present, any version text defined will be displayed
+!! when the program is called with a --version switch,
+!! and then the program will terminate.
+!! IERR if present a non-zero option is returned when an
+!! error occurs instead of the program terminating.
+!! ERRMSG a description of the error if ierr is present.
!!
!!##DEFINING THE PROTOTYPE
!!
+!! o Keywords start with a single dash for short single-character
+!! keywords, and with two dashes for longer keywords.
+!!
!! o all keywords on the prototype MUST get a value.
!!
-!! + logicals must be set to F or T.
+!! * logicals must be set to an unquoted F.
!!
-!! + strings must be delimited with double-quotes and
-!! must be at least one space. Internal double-quotes
-!! are represented with two double-quotes.
+!! * strings must be delimited with double-quotes.
+!! Since internal double-quotes are represented with two
+!! double-quotes the string must be at least one space.
!!
!! o numeric keywords are not allowed; but this allows
!! negative numbers to be used as values.
@@ -500,29 +507,29 @@ end subroutine check_commandline
!! get the value.
!!
!! o to define a zero-length allocatable array make the
-!! value a delimiter (usually a comma).
-!!
-!! o all unused values go into the character array UNNAMED
+!! value a delimiter (usually a comma) or an empty set
+!! of braces ("[]").
!!
!! LONG AND SHORT NAMES
!!
+!! Long keywords start with two dashes followed by more than one letter.
+!! Short keywords are a dash followed by a single letter.
+!!
!! o It is recommended long names (--keyword) should be all lowercase
-!! but are case-sensitive by default, unless set_mode('ignorecase')
+!! but are case-sensitive by default, unless "set_mode('ignorecase')"
!! is in effect.
!!
!! o Long names should always be more than one character.
!!
!! o The recommended way to have short names is to suffix the long
-!! name with :LETTER in the definition. If this syntax is used
-!! then logical shorts may be combined on the command line.
+!! name with :LETTER in the definition.
!!
-!! Mapping of short names to long names __not__ using the
-!! --LONGNAME:SHORTNAME syntax is demonstrated in the manpage
-!! for SPECIFIED(3f).
+!! If this syntax is used then logical shorts may be combined on the
+!! command line when "set_mode('strict')" is in effect.
!!
!! SPECIAL BEHAVIORS
!!
-!! o A very special behavior occurs if the keyword name ends in ::.
+!! o A special behavior occurs if a keyword name ends in ::.
!! When the program is called the next parameter is taken as
!! a value even if it starts with -. This is not generally
!! recommended but is useful in rare cases where non-numeric
@@ -530,45 +537,66 @@ end subroutine check_commandline
!!
!! o If the prototype ends with "--" a special mode is turned
!! on where anything after "--" on input goes into the variable
-!! REMAINING and the array ARGS instead of becoming elements in
-!! the UNNAMED array. This is not needed for normal processing.
+!! REMAINING with values double-quoted and also into the array ARGS
+!! instead of becoming elements in the UNNAMED array. This is not
+!! needed for normal processing, but was needed for a program that
+!! needed this behavior for its subcommands.
!!
-!!##USAGE
-!! When invoking the program line note that (subject to change) the
-!! following variations from other common command-line parsers:
+!! That is, for a normal call all unnamed values go into UNNAMED
+!! and ARGS and REMAINING are ignored. So for
!!
-!! o values for duplicate keywords are appended together with a space
-!! separator when a command line is executed.
+!! call set_args('-x 10 -y 20 ')
!!
-!! o Although not generally recommended you can equivalence
-!! keywords (usually for multi-lingual support). Be aware that
-!! specifying both names of an equivalenced keyword on a command
-!! line will have undefined results (currently, their ASCII
-!! alphabetical order will define what the Fortran variable
-!! values become).
+!! A program invocation such as
!!
-!! The second of the names should only be queried if the
-!! SPECIFIED(3f) function is .TRUE. for that name.
+!! xx a b c -- A B C " dd "
!!
-!! Note that allocatable arrays cannot be EQUIVALENCEd in Fortran.
+!! results in
!!
-!! o short Boolean keywords cannot be combined reliably unless
-!! "set_mode('strict')" is in effect. Short names that require
-!! a value cannot be bundled together. Non-Boolean key names may
-!! not be bundled.
+!! UNNAMED= ['a','b','c','A','B','C',' dd']
+!! REMAINING= ''
+!! ARGS= [character(len=0) :: ] ! ie, an empty character array
+!!
+!! Whereas
+!!
+!! call set_args('-x 10 -y 20 --')
+!!
+!! generates the following output from the same program execution:
+!!
+!! UNNAMED= ['a','b','c']
+!! REMAINING= '"A" "B" "C" " dd "'
+!! ARGS= ['A','B','C,' dd']
+!!
+!!##USAGE NOTES
+!! When invoking the program line note the (subject to change)
+!! following restrictions (which often differ between various
+!! command-line parsers):
+!!
+!! o values for duplicate keywords are appended together with a space
+!! separator when a command line is executed by default.
!!
!! o shuffling is not supported. Values immediately follow their
!! keywords.
!!
+!! o Only short Boolean keywords can be bundled together.
+!! If allowing bundling is desired call "set_mode('strict')".
+!! This will require prefixing long names with "--" and short
+!! names with "-". Otherwise M_CLI2 relaxes that requirement
+!! and mostly does not care what prefix is used for a keyword.
+!! But this would make it unclear what was meant by "-ox" if
+!! allowed options were "-o F -x F --ox F " for example, so
+!! "strict" mode is required to remove the ambiguity.
+!!
!! o if a parameter value of just "-" is supplied it is
!! converted to the string "stdin".
!!
-!! o values not matching a keyword go into the character
-!! array "UNUSED".
+!! o values not needed for a keyword value go into the character
+!! array "UNNAMED".
+!!
+!! In addition if the keyword "--" is encountered on the command
+!! line the rest of the command line goes into the character array
+!! "UNNAMED".
!!
-!! o if the keyword "--" is encountered on the command line the
-!! rest of the command arguments go into the character array
-!! "UNUSED".
!!##EXAMPLE
!!
!!
@@ -597,7 +625,7 @@ end subroutine check_commandline
!! & --title "my title" &
!! ! string should be a single character at a minimum
!! & --label " ", &
-!! ! set all logical values to F or T.
+!! ! set all logical values to F
!! & -l F -L F &
!! ! set allocatable size to zero if you like by using a delimiter
!! & --ints , &
@@ -890,7 +918,7 @@ end subroutine check_commandline
!===================================================================================================================================
subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg)
-! ident_2="@(#) M_CLI2 set_args(3f) parse prototype string"
+! ident_1="@(#) M_CLI2 set_args(3f) parse prototype string"
character(len=*),intent(in) :: prototype
character(len=*),intent(in),optional :: help_text(:)
@@ -911,7 +939,6 @@ subroutine set_args(prototype,help_text,version_text,string,prefix,ierr,errmsg)
G_response=CLI_RESPONSE_FILE
G_options_only=.false.
- G_append=.true.
G_passed_in=''
G_STOP=0
G_STOP_MESSAGE=''
@@ -993,8 +1020,8 @@ end subroutine set_args
!! !x! You can call this program which has two subcommands (run, test),
!! !x! like this:
!! !x! demo_get_subcommand --help
-!! !x! demo_get_subcommand run -x -y -z -title -l -L
-!! !x! demo_get_subcommand test -title -l -L -testname
+!! !x! demo_get_subcommand run -x -y -z --title -l -L
+!! !x! demo_get_subcommand test --title -l -L --testname
!! !x! demo_get_subcommand run --help
!! implicit none
!! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
@@ -1031,8 +1058,8 @@ end subroutine set_args
!! ! general help for "demo_get_subcommand --help"
!! help_text=[character(len=80) :: &
!! ' allowed subcommands are ', &
-!! ' * run -l -L -title -x -y -z ', &
-!! ' * test -l -L -title ', &
+!! ' * run -l -L --title -x -y -z ', &
+!! ' * test -l -L --title ', &
!! '' ]
!! ! find the subcommand name by looking for first word on command
!! ! not starting with dash
@@ -1088,7 +1115,7 @@ end subroutine set_args
!===================================================================================================================================
function get_subcommand() result(sub)
-! ident_3="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"
+! ident_2="@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files"
character(len=:),allocatable :: sub
character(len=:),allocatable :: cmdarg
@@ -1144,6 +1171,36 @@ end function get_subcommand
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
+!>
+!!##NAME
+!! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description
+!! for keywords for the --usage switch
+!! (LICENSE:PD)
+!!
+!!##SYNOPSIS
+!!
+!! subroutine set_usage(keyword,description)
+!!
+!! character(len=*),intent(in) :: keyword
+!! character(len=*),intent(in) :: description
+!!
+!!##DESCRIPTION
+!!
+!!##OPTIONS
+!! KEYWORD the name of a command keyword
+!! DESCRIPTION a brief one-line description of the keyword
+!!
+!!
+!!##EXAMPLE
+!!
+!! sample program:
+!!
+!! Results:
+!!
+!!##AUTHOR
+!! John S. Urban, 2019
+!!##LICENSE
+!! Public Domain
!===================================================================================================================================
subroutine set_usage(keyword,description,value)
character(len=*),intent(in) :: keyword
@@ -1187,7 +1244,7 @@ end subroutine set_usage
!!
!! o logical values
!!
-!! o logical values must have a value
+!! o logical values must have a value. Use F.
!!
!! o leading and trailing blanks are removed from unquoted values
!!
@@ -1201,7 +1258,10 @@ end subroutine set_usage
!!
!! sample program:
!!
-!! Results:
+!! call prototype_to_dictionary(' -l F --ignorecase F --title "my title string" -x 10.20')
+!! call prototype_to_dictionary(' --ints 1,2,3,4')
+!!
+!! Results:
!!
!!##AUTHOR
!! John S. Urban, 2019
@@ -1210,7 +1270,7 @@ end subroutine set_usage
!===================================================================================================================================
recursive subroutine prototype_to_dictionary(string)
-! ident_4="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary"
+! ident_3="@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary"
character(len=*),intent(in) :: string ! string is character input string of options and values
@@ -1277,8 +1337,10 @@ recursive subroutine prototype_to_dictionary(string)
endif
enddo TESTIT
if(keyword /= ' ')then
+ if(value=='[]')value=','
call update(keyword,value) ! store name and its value
elseif( G_remaining_option_allowed)then ! meaning "--" has been encountered
+ if(value=='[]')value=','
call update('_args_',trim(value))
else
!x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword)
@@ -1371,9 +1433,20 @@ end subroutine prototype_to_dictionary
!! specified(3f) returns .true. if the specified keyword was present on
!! the command line.
!!
+!! M_CLI2 intentionally does not have validators except for SPECIFIED(3f)
+!! and of course a check whether the input conforms to the type when
+!! requesting a value (with get_args(3f) or the convenience functions
+!! like inum(3f)).
+!!
+!! Fortran already has powerful validation capabilities. Logical
+!! expressions ANY(3f) and ALL(3f) are standard Fortran features which
+!! easily allow performing the common validations for command line
+!! arguments without having to learn any additional syntax or methods.
+!!
!!##OPTIONS
!!
-!! NAME name of commandline argument to query the presence of
+!! NAME name of commandline argument to query the presence of. Long
+!! names should always be used.
!!
!!##RETURNS
!! SPECIFIED returns .TRUE. if specified NAME was present on the command
@@ -1384,48 +1457,102 @@ end subroutine prototype_to_dictionary
!! Sample program:
!!
!! program demo_specified
-!! use M_CLI2, only : set_args, get_args, specified
+!! use, intrinsic :: iso_fortran_env, only : &
+!! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
+!! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget
!! implicit none
-!! ! DEFINE ARGS
-!! integer :: flag
-!! integer,allocatable :: ints(:)
-!! real,allocatable :: two_names(:)
!!
-!! ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED
-!! ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM
+!! ! Define args
+!! integer,allocatable :: ints(:)
+!! real,allocatable :: floats(:)
+!! logical :: flag
+!! character(len=:),allocatable :: color
+!! character(len=:),allocatable :: list(:)
+!! integer :: i
+!!
!! call set_args('&
-!! & --flag 1 -f 1 &
-!! & --ints 1,2,3 -i 1,2,3 &
-!! & --two_names 11.3 -T 11.3')
-!!
-!! ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME
-!! call get_args('flag',flag)
-!! if(specified('f'))call get_args('f',flag)
-!! call get_args('ints',ints)
-!! if(specified('i'))call get_args('i',ints)
-!! call get_args('two_names',two_names)
-!! if(specified('T'))call get_args('T',two_names)
-!!
-!! ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE
+!! & --color:c "red" &
+!! & --flag:f F &
+!! & --ints:i 1,10,11 &
+!! & --floats:T 12.3, 4.56 &
+!! & ')
+!! ints=igets('ints')
+!! floats=rgets('floats')
+!! flag=lget('flag')
+!! color=sget('color')
+!!
+!! write(*,*)'color=',color
+!! write(*,*)'flag=',flag
+!! write(*,*)'ints=',ints
+!! write(*,*)'floats=',floats
+!!
+!! write(*,*)'was -flag specified?',specified('flag')
+!!
+!! ! elemental
+!! write(*,*)specified(['floats','ints '])
+!!
+!! ! If you want to know if groups of parameters were specified use
!! ! ANY(3f) and ALL(3f)
-!! write(*,*)specified(['two_names','T '])
-!! write(*,*)'ANY:',any(specified(['two_names','T ']))
-!! write(*,*)'ALL:',all(specified(['two_names','T ']))
+!! write(*,*)'ANY:',any(specified(['floats','ints ']))
+!! write(*,*)'ALL:',all(specified(['floats','ints ']))
!!
-!! ! FOR MUTUALLY EXCLUSIVE
-!! if (all(specified(['two_names','T '])))then
-!! write(*,*)'You specified both names -T and -two_names'
+!! ! For mutually exclusive
+!! if (all(specified(['floats','ints '])))then
+!! write(*,*)'You specified both names --ints and --floats'
!! endif
!!
-!! ! FOR REQUIRED PARAMETER
-!! if (.not.any(specified(['two_names','T '])))then
-!! write(*,*)'You must specify -T or -two_names'
+!! ! For required parameter
+!! if (.not.any(specified(['floats','ints '])))then
+!! write(*,*)'You must specify --ints or --floats'
!! endif
-!! ! USE VALUES
-!! write(*,*)'flag=',flag
-!! write(*,*)'ints=',ints
-!! write(*,*)'two_names=',two_names
-!! end program demo_specified
+!!
+!! ! check if all values are in range from 10 to 30 and even
+!! write(*,*)'are all numbers good?',all([ints >= 10,ints <= 30,(ints/2)*2 == ints])
+!!
+!! ! perhaps you want to check one value at a time
+!! do i=1,size(ints)
+!! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]
+!! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then
+!! write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+!! else
+!! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+!! endif
+!! enddo
+!!
+!! list = [character(len=10) :: 'red','white','blue']
+!! if( any(color == list) )then
+!! write(*,*)color,'matches a value in the list'
+!! else
+!! write(*,*)color,'not in the list'
+!! endif
+!!
+!! if(size(ints).eq.3)then
+!! write(*,*)'ints(:) has expected number of values'
+!! else
+!! write(*,*)'ints(:) does not have expected number of values'
+!! endif
+!!
+!! end program demo_specified
+!!
+!! Default output
+!!
+!! > color=red
+!! > flag= F
+!! > ints= 1 10 11
+!! > floats= 12.3000002 4.55999994
+!! > was -flag specified? F
+!! > F F
+!! > ANY: F
+!! > ALL: F
+!! > You must specify --ints or --floats
+!! > 1 F T F
+!! > 1 is not an even number from 10 to 30 inclusive
+!! > 10 T T T
+!! > 10 is an even number from 10 to 30 inclusive
+!! > 11 T T F
+!! > 11 is not an even number from 10 to 30 inclusive
+!! > red matches a value in the list
+!! > ints(:) has expected number of values
!!
!!##AUTHOR
!! John S. Urban, 2019
@@ -1485,7 +1612,7 @@ subroutine update(key,val)
integer :: isize
logical :: set_mandatory
set_mandatory=.false.
- call split(trim(key),long_short,':',nulls='return') ! split long:short keyname or long:short:: or long:: or short::
+ call split(trim(key),long_short,':',nulls='return') ! split long:short keyword or long:short:: or long:: or short::
! check for :: on end
isize=size(long_short)
@@ -1520,10 +1647,12 @@ subroutine update(key,val)
long=trim(long_short(1))
short=trim(long_short(2))
end select
- if(G_UNDERDASH)then
- long=replace_str(long,'-','_')
+ if(G_UNDERDASH) long=replace_str(long,'-','_')
+ if(G_NOSEPARATOR)then
+ long=replace_str(long,'-','')
+ long=replace_str(long,'_','')
endif
- if(G_IGNORECASE.and.len(long) > 1)long=lower(long)
+ if(G_IGNORECASE.and.len_trim(long) > 1)long=lower(long)
if(present(val))then
val_local=val
iilen=len_trim(val_local)
@@ -1645,7 +1774,7 @@ end function get
!!
!! subroutine prototype_and_cmd_args_to_nlist(prototype)
!!
-!! character(len=*) :: prototype
+!! character(len=*) :: prototype
!!##DESCRIPTION
!! create dictionary with character keywords, values, and value lengths
!! using the routines for maintaining a list from command line arguments.
@@ -1670,7 +1799,7 @@ end function get
!! complex :: c
!! doubleprecision :: x,y,z
!!
-!! ! uppercase keywords get an underscore to make it easier o remember
+!! ! uppercase keywords get an underscore to make it easier to remember
!! logical :: l_,h_,v_
!! ! character variables must be long enough to hold returned value
!! character(len=256) :: a_,b_
@@ -1701,7 +1830,7 @@ end function get
!===================================================================================================================================
subroutine prototype_and_cmd_args_to_nlist(prototype,string)
-! ident_5="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line"
+! ident_4="@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line"
character(len=*),intent(in) :: prototype
character(len=*),intent(in),optional :: string
@@ -2052,7 +2181,7 @@ function join_path(a1,a2,a3,a4,a5) result(path)
if (present(a4)) path = path // filesep // trim(a4)
if (present(a5)) path = path // filesep // trim(a5)
path=adjustl(path//' ')
- call substitute(path,filesep//filesep,'',start=2) ! some systems allow names starting with '//' or '\\'
+ path=path(1:1)//replace_str(path,filesep//filesep,'') ! some systems allow names starting with '//' or '\\'
path=trim(path)
end function join_path
!===================================================================================================================================
@@ -2223,7 +2352,9 @@ subroutine cmd_args_to_dictionary()
lastkeyword=' '
G_keyword_single_letter=.true.
i=1
+ current_argument=''
GET_ARGS: do while (get_next_argument()) ! insert and replace entries
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:WHILE:CURRENT_ARGUMENT=',current_argument
if( current_argument == '-' .and. nomore .eqv. .true. )then ! sort of
elseif( current_argument == '-')then ! sort of
@@ -2242,9 +2373,8 @@ subroutine cmd_args_to_dictionary()
dummy=current_argument//' '
current_argument_padded=current_argument//' '
- !x!guess_if_value=maybe_value()
-
if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == '--')then ! beginning of long word
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_LONG:'
G_keyword_single_letter=.false.
if(lastkeyword /= '')then
call ifnull()
@@ -2267,45 +2397,57 @@ subroutine cmd_args_to_dictionary()
& .and.current_argument_padded(1:1) == '-' &
& .and.index("0123456789.",dummy(2:2)) == 0)then
! short word
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:START_SHORT'
G_keyword_single_letter=.true.
if(lastkeyword /= '')then
call ifnull()
endif
call locate_key(current_argument_padded(2:),pointer)
- if(pointer <= 0)then ! name not found
- jj=len(current_argument)
- if(G_STRICT.and.jj > 2)then ! in strict mode this might be multiple single-character values
- do kk=2,jj
- letter=current_argument_padded(kk:kk)
- call locate_key(letter,pointer)
- if(pointer > 0)then
- call update(keywords(pointer),'T')
- else
- call print_dictionary('UNKNOWN COMPOUND SHORT KEYWORD:'//letter//' in '//current_argument)
- if(G_QUIET)then
- lastkeyword="UNKNOWN"
- pointer=0
- cycle GET_ARGS
- endif
- call mystop(2)
- return
- endif
- current_argument='-'//current_argument_padded(jj:jj)
- enddo
- else
- call print_dictionary('UNKNOWN SHORT KEYWORD: '//current_argument)
- if(G_QUIET)then
- lastkeyword="UNKNOWN"
- pointer=0
- cycle GET_ARGS
+ jj=len(current_argument)
+ if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT NOT FOUND:',current_argument_padded(2:)
+ ! in strict mode this might be multiple single-character values
+ do kk=2,jj
+ letter=current_argument_padded(kk:kk)
+ call locate_key(letter,pointer)
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:LETTER:',letter,pointer
+ if(pointer > 0)then
+ call update(keywords(pointer),'T')
+ else
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT:',letter
+ call print_dictionary('UNKNOWN SHORT KEYWORD:'//letter) ! //' in '//current_argument)
+ if(G_QUIET)then
+ lastkeyword="UNKNOWN"
+ pointer=0
+ cycle GET_ARGS
+ endif
+ call mystop(2)
+ return
endif
- call mystop(2)
- return
+ current_argument='-'//current_argument_padded(jj:jj)
+ enddo
+ !--------------
+ lastkeyword=""
+ pointer=0
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:2:'
+ cycle GET_ARGS
+ !--------------
+ elseif(pointer<0)then
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNKNOWN SHORT_CONFIRMED:',letter
+ call print_dictionary('UNKNOWN SHORT KEYWORD:'//current_argument_padded(2:))
+ if(G_QUIET)then
+ lastkeyword="UNKNOWN"
+ pointer=0
+ cycle GET_ARGS
endif
+ call mystop(2)
+ return
endif
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:SHORT_END:1:'
lastkeyword=trim(current_argument_padded(2:))
next_mandatory=mandatory(pointer)
elseif(pointer == 0)then ! unnamed arguments
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:UNNAMED ARGUMENT:',current_argument
if(G_remaining_on)then
if(len(current_argument) < 1)then
G_remaining=G_remaining//'"" '
@@ -2327,6 +2469,7 @@ subroutine cmd_args_to_dictionary()
endif
endif
else
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:FOUND:',current_argument
oldvalue=get(keywords(pointer))//' '
if(oldvalue(1:1) == '"')then
current_argument=quote(current_argument(:ilength))
@@ -2347,10 +2490,10 @@ subroutine cmd_args_to_dictionary()
else
imax=max(len(unnamed),len(current_argument))
if(scan(current_argument//' ','@') == 1.and.G_response)then
- if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
- call expand_response(current_argument)
+ if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument
+ call expand_response(current_argument)
else
- unnamed=[character(len=imax) :: unnamed,current_argument]
+ unnamed=[character(len=imax) :: unnamed,current_argument]
endif
endif
endif
@@ -2447,40 +2590,6 @@ function get_next_argument()
i=i+1
end function get_next_argument
-function maybe_value()
-! if previous keyword value type is a string and it was
-! given a null string because this value starts with a -
-! try to see if this is a string value starting with a -
-! to try to solve the vexing problem of values starting
-! with a dash.
-logical :: maybe_value
-integer :: pointer
-character(len=:),allocatable :: oldvalue
-
- oldvalue=get(lastkeyword)//' '
- if(current_argument_padded(1:1) /= '-')then
- maybe_value=.true.
- elseif(oldvalue(1:1) /= '"')then
- maybe_value=.false.
- elseif(index(current_argument,' ') /= 0)then
- maybe_value=.true.
- elseif(scan(current_argument,",:;!@#$%^&*+=()[]{}\|'""./> 0)then
write(warn,'(a,1x,a,1x,a,1x,a)')atleast('KEYWORD',max(len(keywords),8)),'SHORT','PRESENT','VALUE'
write(warn,'(*(a,1x,a5,1x,l1,8x,"[",a,"]",/))') &
- & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=1,size(keywords))
+ & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1)
endif
endif
if(allocated(unnamed))then
@@ -2581,62 +2690,6 @@ end subroutine print_dictionary
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
-FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status)
-! JSU- 20151030
-
-! ident_6="@(#) M_CLI2 strtok(3f) Tokenize a string"
-
-character(len=*),intent(in) :: source_string ! Source string to tokenize.
-character(len=*),intent(in) :: delimiters ! list of separator characters. May change between calls
-integer,intent(inout) :: itoken ! token count since started
-logical :: strtok_status ! returned value
-integer,intent(out) :: token_start ! beginning of token found if function result is .true.
-integer,intent(inout) :: token_end ! end of token found if function result is .true.
-integer :: isource_len
-!----------------------------------------------------------------------------------------------------------------------------
-! calculate where token_start should start for this pass
- if(itoken <= 0)then ! this is assumed to be the first call
- token_start=1
- else ! increment start to previous end + 1
- token_start=token_end+1
- endif
-!----------------------------------------------------------------------------------------------------------------------------
- isource_len=len(source_string) ! length of input string
-!----------------------------------------------------------------------------------------------------------------------------
- if(token_start > isource_len)then ! user input error or at end of string
- token_end=isource_len ! assume end of token is end of string until proven otherwise so it is set
- strtok_status=.false.
- return
- endif
-!----------------------------------------------------------------------------------------------------------------------------
- ! find beginning of token
- do while (token_start <= isource_len) ! step thru each character to find next delimiter, if any
- if(index(delimiters,source_string(token_start:token_start)) /= 0) then
- token_start = token_start + 1
- else
- exit
- endif
- enddo
-!----------------------------------------------------------------------------------------------------------------------------
- token_end=token_start
- do while (token_end <= isource_len-1) ! step thru each character to find next delimiter, if any
- if(index(delimiters,source_string(token_end+1:token_end+1)) /= 0) then ! found a delimiter in next character
- exit
- endif
- token_end = token_end + 1
- enddo
-!----------------------------------------------------------------------------------------------------------------------------
- if (token_start > isource_len) then ! determine if finished
- strtok_status=.false. ! flag that input string has been completely processed
- else
- itoken=itoken+1 ! increment count of tokens found
- strtok_status=.true. ! flag more tokens may remain
- endif
-!----------------------------------------------------------------------------------------------------------------------------
-end function strtok
-!==================================================================================================================================!
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!==================================================================================================================================!
!>
!!##NAME
!! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing
@@ -2666,9 +2719,9 @@ end function strtok
!! {real,doubleprecision,integer,logical,complex,character(len=:)}
!!##DESCRIPTION
!!
-!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f)
-!! has been called. For fixed-length CHARACTER variables
-!! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has
+!! been called to parse the command line. For fixed-length CHARACTER
+!! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
!! GET_ARGS_FIXED_SIZE(3f).
!!
!! As a convenience multiple pairs of keywords and variables may be
@@ -2687,7 +2740,6 @@ end function strtok
!! list of delimiter characters may be supplied.
!!
!!##CONVENIENCE FUNCTIONS
-!!
!! There are convenience functions that are replacements for calls to
!! get_args(3f) for each supported default intrinsic type
!!
@@ -2711,31 +2763,29 @@ end function strtok
!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
!! implicit none
!! integer :: i
-!! ! DEFINE ARGS
+!! ! Define ARGS
!! real :: x, y, z
!! real,allocatable :: p(:)
!! character(len=:),allocatable :: title
!! logical :: l, lbig
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o only quote strings and use double-quotes
-!! ! o set all logical values to F or T.
-!! call set_args(' &
-!! & -x 1 -y 2 -z 3 &
-!! & -p -1,-2,-3 &
+!! ! Define and parse (to set initial values) command line
+!! ! o only quote strings and use double-quotes
+!! ! o set all logical values to F or T.
+!! call set_args(' &
+!! & -x 1 -y 2 -z 3 &
+!! & -p -1,-2,-3 &
!! & --title "my title" &
-!! & -l F -L F &
-!! & --label " " &
+!! & -l F -L F &
+!! & --label " " &
!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! ! SCALARS
-!! call get_args('x',x,'y',y,'z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! ! ALLOCATABLE STRING
+!! ! Assign values to elements
+!! ! Scalars
+!! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+!! ! Allocatable string
!! call get_args('title',title)
-!! ! NON-ALLOCATABLE ARRAYS
+!! ! Allocatable arrays
!! call get_args('p',p)
-!! ! USE VALUES
+!! ! Use values
!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
!! write(*,*)'p=',p
!! write(*,*)'title=',title
@@ -2760,12 +2810,13 @@ end function strtok
!!
!! subroutine get_args_fixed_length(name,value)
!!
+!! character(len=*),intent(in) :: name
!! character(len=:),allocatable :: value
!! character(len=*),intent(in),optional :: delimiters
!!
!!##DESCRIPTION
!!
-!! GET_ARGS_fixed_length(3f) returns the value of a string
+!! get_args_fixed_length(3f) returns the value of a string
!! keyword when the string value is a fixed-length CHARACTER
!! variable.
!!
@@ -2787,15 +2838,16 @@ end function strtok
!! program demo_get_args_fixed_length
!! use M_CLI2, only : set_args, get_args_fixed_length
!! implicit none
-!! ! DEFINE ARGS
+!!
+!! ! Define args
!! character(len=80) :: title
-!! call set_args(' &
-!! & --title "my title" &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args_fixed_length('title',title)
-!! ! USE VALUES
-!! write(*,*)'title=',title
+!! ! Parse command line
+!! call set_args(' --title "my title" ')
+!! ! Assign values to variables
+!! call get_args_fixed_length('title',title)
+!! ! Use values
+!! write(*,*)'title=',title
+!!
!! end program demo_get_args_fixed_length
!!
!!##AUTHOR
@@ -2813,6 +2865,7 @@ end function strtok
!!
!! subroutine get_args_fixed_size(name,value)
!!
+!! character(len=*),intent(in) :: name
!! [real|doubleprecision|integer|logical|complex] :: value(NNN)
!! or
!! character(len=MMM) :: value(NNN)
@@ -2821,10 +2874,9 @@ end function strtok
!!
!!##DESCRIPTION
!!
-!! GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for
-!! fixed-size arrays after SET_ARGS(3f) has been called.
-!! On input on the command line all values of the array must
-!! be specified.
+!! get_args_fixed_size(3f) returns the value of keywords for fixed-size
+!! arrays after set_args(3f) has been called. On input on the command
+!! line all values of the array must be specified.
!!
!!##OPTIONS
!! NAME name of commandline argument to obtain the value of
@@ -2907,7 +2959,7 @@ end subroutine get_fixedarray_class
!===================================================================================================================================
subroutine get_anyarray_l(keyword,larray,delimiters)
-! ident_7="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)"
+! ident_5="@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)"
character(len=*),intent(in) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve
logical,allocatable :: larray(:) ! convert value to an array
@@ -2922,7 +2974,7 @@ subroutine get_anyarray_l(keyword,larray,delimiters)
val=values(place)(:counts(place))
call split(adjustl(upper(val)),carray,delimiters=delimiters) ! convert value to uppercase, trimmed; then parse into array
else
- call journal('sc','*get_anyarray_l* unknown keyword '//keyword)
+ call journal('*get_anyarray_l* unknown keyword',keyword)
call mystop(8 ,'*get_anyarray_l* unknown keyword '//keyword)
if(allocated(larray))deallocate(larray)
allocate(larray(0))
@@ -2942,7 +2994,7 @@ subroutine get_anyarray_l(keyword,larray,delimiters)
case('T','Y',' '); larray(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
case('F','N'); larray(i)=.false. ! assume this is false or no
case default
- call journal('sc',"*get_anyarray_l* bad logical expression for "//trim(keyword)//'='//carray(i))
+ call journal("*get_anyarray_l* bad logical expression for ",(keyword),'=',carray(i))
end select
enddo
else ! for a blank string return one T
@@ -2954,7 +3006,7 @@ end subroutine get_anyarray_l
!===================================================================================================================================
subroutine get_anyarray_d(keyword,darray,delimiters)
-! ident_8="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)"
+! ident_6="@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)"
character(len=*),intent(in) :: keyword ! keyword to retrieve value from dictionary
real(kind=dp),allocatable,intent(out) :: darray(:) ! function type
@@ -2973,7 +3025,7 @@ subroutine get_anyarray_d(keyword,darray,delimiters)
val=replace_str(val,')','')
call split(val,carray,delimiters=delimiters) ! find value associated with keyword and split it into an array
else
- call journal('sc','*get_anyarray_d* unknown keyword '//keyword)
+ call journal('*get_anyarray_d* unknown keyword '//keyword)
call mystop(9 ,'*get_anyarray_d* unknown keyword '//keyword)
if(allocated(darray))deallocate(darray)
allocate(darray(0))
@@ -3017,7 +3069,7 @@ subroutine get_anyarray_x(keyword,xarray,delimiters)
sz=size(darray)
half=sz/2
if(sz /= half+half)then
- call journal('sc','*get_anyarray_x* uneven number of values defining complex value '//keyword)
+ call journal('*get_anyarray_x* uneven number of values defining complex value '//keyword)
call mystop(11,'*get_anyarray_x* uneven number of values defining complex value '//keyword)
if(allocated(xarray))deallocate(xarray)
allocate(xarray(0))
@@ -3049,7 +3101,7 @@ subroutine get_anyarray_c(keyword,strings,delimiters)
val=unquote(values(place)(:counts(place)))
call split(val,strings,delimiters=delimiters) ! find value associated with keyword and split it into an array
else
- call journal('sc','*get_anyarray_c* unknown keyword '//keyword)
+ call journal('*get_anyarray_c* unknown keyword '//keyword)
call mystop(12,'*get_anyarray_c* unknown keyword '//keyword)
if(allocated(strings))deallocate(strings)
allocate(character(len=0)::strings(0))
@@ -3059,7 +3111,7 @@ end subroutine get_anyarray_c
!===================================================================================================================================
subroutine get_args_fixed_length_a_array(keyword,strings,delimiters)
-! ident_9="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
+! ident_7="@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
character(len=*),intent(in) :: keyword ! name to look up in dictionary
@@ -3077,14 +3129,14 @@ subroutine get_args_fixed_length_a_array(keyword,strings,delimiters)
strings=strings_a
else
ibug=len(strings)
- call journal('sc','*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug)
+ call journal('*get_args_fixed_length_a_array* values too long. Longest is',len(strings_a),'allowed is',ibug)
write(*,'("strings=",3x,*(a,1x))')strings
- call journal('sc','*get_args_fixed_length_a_array* keyword='//keyword)
+ call journal('*get_args_fixed_length_a_array* keyword='//keyword)
call mystop(13,'*get_args_fixed_length_a_array* keyword='//keyword)
strings=[character(len=len(strings)) ::]
endif
else
- call journal('sc','*get_args_fixed_length_a_array* unknown keyword '//keyword)
+ call journal('*get_args_fixed_length_a_array* unknown keyword '//keyword)
call mystop(14,'*get_args_fixed_length_a_array* unknown keyword '//keyword)
strings=[character(len=len(strings)) ::]
endif
@@ -3105,7 +3157,7 @@ subroutine get_fixedarray_i(keyword,iarray,delimiters)
iarray=nint(darray)
else
ibug=size(iarray)
- call journal('sc','*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+ call journal('*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
call print_dictionary('USAGE:')
call mystop(33)
iarray=0
@@ -3125,7 +3177,7 @@ subroutine get_fixedarray_r(keyword,rarray,delimiters)
rarray=darray
else
ibug=size(rarray)
- call journal('sc','*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+ call journal('*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
call print_dictionary('USAGE:')
call mystop(33)
rarray=0.0
@@ -3145,7 +3197,7 @@ subroutine get_fixed_size_complex(keyword,xarray,delimiters)
sz=dsize*2
half=sz/2
if(sz /= half+half)then
- call journal('sc','*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
+ call journal('*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
call mystop(15,'*get_fixed_size_complex* uneven number of values defining complex value '//keyword)
xarray=0
return
@@ -3154,7 +3206,7 @@ subroutine get_fixed_size_complex(keyword,xarray,delimiters)
xarray=darray
else
ibug=size(xarray)
- call journal('sc','*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+ call journal('*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
call print_dictionary('USAGE:')
call mystop(34)
xarray=cmplx(0.0,0.0)
@@ -3174,7 +3226,7 @@ subroutine get_fixedarray_d(keyword,darr,delimiters)
darr=darray
else
ibug=size(darr)
- call journal('sc','*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+ call journal('*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
call print_dictionary('USAGE:')
call mystop(35)
darr=0.0d0
@@ -3194,7 +3246,7 @@ subroutine get_fixedarray_l(keyword,larray,delimiters)
larray=darray
else
ibug=size(larray)
- call journal('sc','*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
+ call journal('*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',ibug)
call print_dictionary('USAGE:')
call mystop(36)
larray=.false.
@@ -3203,7 +3255,7 @@ end subroutine get_fixedarray_l
!===================================================================================================================================
subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters)
-! ident_10="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
+! ident_8="@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary"
! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
character(len=*) :: strings(:)
@@ -3223,14 +3275,14 @@ subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters)
strings(:ssize)=str
else
ibug=size(strings)
- call journal('sc','*get_fixedarray_fixed_length_c* wrong number of values for keyword',&
+ call journal('*get_fixedarray_fixed_length_c* wrong number of values for keyword',&
& keyword,'got',ssize,'expected ',ibug) !,ubound(strings,dim=1)
call print_dictionary('USAGE:')
call mystop(30,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
strings=''
endif
else
- call journal('sc','*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
+ call journal('*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
call mystop(16,'*get_fixedarray_fixed_length_c* unknown keyword '//keyword)
strings=''
endif
@@ -3248,9 +3300,9 @@ subroutine get_scalar_d(keyword,d)
d=darray(1)
else
ibug=size(darray)
- call journal('sc','*get_anyarray_d* incorrect number of values for keyword',keyword,'expected one found',ibug)
+ call journal('*get_anyarray_d* incorrect number of values for keyword "',keyword,'" expected one found',ibug)
call print_dictionary('USAGE:')
- call mystop(31,'*get_anyarray_d* incorrect number of values for keyword'//keyword//'expected one')
+ call mystop(31,'*get_anyarray_d* incorrect number of values for keyword "'//keyword//'" expected one')
endif
end subroutine get_scalar_d
!===================================================================================================================================
@@ -3272,7 +3324,7 @@ end subroutine get_scalar_i
!===================================================================================================================================
subroutine get_scalar_anylength_c(keyword,string)
-! ident_11="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
+! ident_9="@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
character(len=*),intent(in) :: keyword ! name to look up in dictionary
@@ -3283,14 +3335,14 @@ subroutine get_scalar_anylength_c(keyword,string)
string=unquote(values(place)(:counts(place)))
else
call mystop(17,'*get_anyarray_c* unknown keyword '//keyword)
- call journal('sc','*get_anyarray_c* unknown keyword '//keyword)
+ call journal('*get_anyarray_c* unknown keyword '//keyword)
string=''
endif
end subroutine get_scalar_anylength_c
!===================================================================================================================================
elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string)
-! ident_12="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
+! ident_10="@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary"
! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary
character(len=*),intent(in) :: keyword ! name to look up in dictionary
@@ -3308,7 +3360,7 @@ elemental impure subroutine get_args_fixed_length_scalar_c(keyword,string)
unlen=len_trim(unquote(values(place)(:counts(place))))
if(unlen>len(string))then
ibug=len(string)
- call journal('sc','*get_args_fixed_length_scalar_c* value too long for',keyword,'allowed is',ibug,&
+ call journal('*get_args_fixed_length_scalar_c* value too long for',keyword,'allowed is',ibug,&
& 'input string [',values(place),'] is',unlen)
call mystop(19,'*get_args_fixed_length_scalar_c* value too long')
string=''
@@ -3331,14 +3383,14 @@ subroutine get_scalar_logical(keyword,l)
l=.false.
call get_anyarray_l(keyword,larray)
if(.not.allocated(larray) )then
- call journal('sc','*get_scalar_logical* expected one value found not allocated')
- call mystop(37,'*get_scalar_logical* incorrect number of values for keyword '//keyword)
+ call journal('*get_scalar_logical* expected one value found not allocated')
+ call mystop(37,'*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"')
elseif(size(larray) == 1)then
l=larray(1)
else
ibug=size(larray)
- call journal('sc','*get_scalar_logical* expected one value found',ibug)
- call mystop(21,'*get_scalar_logical* incorrect number of values for keyword '//keyword)
+ call journal('*get_scalar_logical* expected one value found',ibug)
+ call mystop(21,'*get_scalar_logical* incorrect number of values for keyword "'//keyword//'"')
endif
end subroutine get_scalar_logical
!===================================================================================================================================
@@ -3404,81 +3456,46 @@ end function longest_command_argument
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
-subroutine journal(where, g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep)
-
-! ident_13="@(#) M_CLI2 journal(3f) writes a message to a string composed of any standard scalar types"
-
-character(len=*),intent(in) :: where
-class(*),intent(in) :: g0
-class(*),intent(in),optional :: g1, g2, g3, g4, g5, g6, g7, g8 ,g9
-class(*),intent(in),optional :: ga, gb, gc, gd, ge, gf, gg, gh ,gi, gj
-character(len=*),intent(in),optional :: sep
-write(*,'(a)')str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep)
-end subroutine journal
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
!>
!!##NAME
-!! str(3f) - [M_CLI2] converts any standard scalar type to a string
+!! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message
!! (LICENSE:PD)
!!##SYNOPSIS
!!
-!! function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
+!! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
!!
!! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
!! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
!! character(len=*),intent(in),optional :: sep
-!! character,len=(:),allocatable :: str
!!
!!##DESCRIPTION
-!! str(3f) builds a space-separated string from up to twenty scalar values.
+!! journal(3f) builds and prints a space-separated string from up to twenty scalar values.
!!
!!##OPTIONS
!! g[0-9a-j] optional value to print the value of after the message. May
!! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
!! COMPLEX, or CHARACTER.
!!
-!! Optionally, all the generic values can be
-!! single-dimensioned arrays. Currently, mixing scalar
-!! arguments and array arguments is not supported.
-!!
!! sep separator to place between values. Defaults to a space.
!!##RETURNS
-!! str description to print
+!! journal description to print
!!##EXAMPLES
!!
!! Sample program:
!!
-!! program demo_str
-!! use M_CLI2, only : str
-!! implicit none
-!! character(len=:),allocatable :: pr
-!! character(len=:),allocatable :: frmt
-!! integer :: biggest
+!! program demo_journal
+!! use M_CLI2, only : journal
+!! implicit none
+!! character(len=:),allocatable :: frmt
+!! integer :: biggest
!!
-!! pr=str('HUGE(3f) integers',huge(0),'and real',&
+!! call journal('HUGE(3f) integers',huge(0),'and real',&
!! & huge(0.0),'and double',huge(0.0d0))
-!! write(*,'(a)')pr
-!! pr=str('real :',huge(0.0),0.0,12345.6789,tiny(0.0) )
-!! write(*,'(a)')pr
-!! pr=str('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) )
-!! write(*,'(a)')pr
-!! pr=str('complex :',cmplx(huge(0.0),tiny(0.0)) )
-!! write(*,'(a)')pr
-!!
-!! ! create a format on the fly
-!! biggest=huge(0)
-!! frmt=str('(*(i',nint(log10(real(biggest))),':,1x))',sep=' ')
-!! write(*,*)'format=',frmt
-!!
-!! ! although it will often work, using str(3f) in an I/O statement
-!! ! is not recommended because if an error occurs str(3f) will try
-!! ! to write while part of an I/O statement which not all compilers
-!! ! can handle and is currently non-standard
-!! write(*,*)str('program will now stop')
-!!
-!! end program demo_str
+!! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) )
+!! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) )
+!! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) )
+!!
+!! end program demo_journal
!!
!! Output
!!
@@ -3495,22 +3512,16 @@ end subroutine journal
!! John S. Urban
!!##LICENSE
!! Public Domain
-function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, &
- & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, &
- & sep)
+subroutine journal(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, sep)
-! ident_14="@(#) M_CLI2 msg_scalar(3fp) writes a message to a string composed of any standard scalar types"
+! ident_11="@(#) M_CLI2 journal(3fp) writes a message to a string composed of any standard scalar types"
-class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4
-class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9
-class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice
-class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj
+class(*),intent(in),optional :: g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj
character(len=*),intent(in),optional :: sep
-character(len=:),allocatable :: sep_local
-character(len=:), allocatable :: msg_scalar
-character(len=4096) :: line
-integer :: istart
-integer :: increment
+character(len=:),allocatable :: sep_local
+character(len=4096) :: line
+integer :: istart
+integer :: increment
if(present(sep))then
sep_local=sep
increment=len(sep_local)+1
@@ -3521,27 +3532,27 @@ function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5,
istart=1
line=''
- if(present(generic0))call print_generic(generic0)
- if(present(generic1))call print_generic(generic1)
- if(present(generic2))call print_generic(generic2)
- if(present(generic3))call print_generic(generic3)
- if(present(generic4))call print_generic(generic4)
- if(present(generic5))call print_generic(generic5)
- if(present(generic6))call print_generic(generic6)
- if(present(generic7))call print_generic(generic7)
- if(present(generic8))call print_generic(generic8)
- if(present(generic9))call print_generic(generic9)
- if(present(generica))call print_generic(generica)
- if(present(genericb))call print_generic(genericb)
- if(present(genericc))call print_generic(genericc)
- if(present(genericd))call print_generic(genericd)
- if(present(generice))call print_generic(generice)
- if(present(genericf))call print_generic(genericf)
- if(present(genericg))call print_generic(genericg)
- if(present(generich))call print_generic(generich)
- if(present(generici))call print_generic(generici)
- if(present(genericj))call print_generic(genericj)
- msg_scalar=trim(line)
+ if(present(g0))call print_generic(g0)
+ if(present(g1))call print_generic(g1)
+ if(present(g2))call print_generic(g2)
+ if(present(g3))call print_generic(g3)
+ if(present(g4))call print_generic(g4)
+ if(present(g5))call print_generic(g5)
+ if(present(g6))call print_generic(g6)
+ if(present(g7))call print_generic(g7)
+ if(present(g8))call print_generic(g8)
+ if(present(g9))call print_generic(g9)
+ if(present(ga))call print_generic(ga)
+ if(present(gb))call print_generic(gb)
+ if(present(gc))call print_generic(gc)
+ if(present(gd))call print_generic(gd)
+ if(present(ge))call print_generic(ge)
+ if(present(gf))call print_generic(gf)
+ if(present(gg))call print_generic(gg)
+ if(present(gh))call print_generic(gh)
+ if(present(gi))call print_generic(gi)
+ if(present(gj))call print_generic(gj)
+ write(*,'(a)')trim(line)
contains
!===================================================================================================================================
subroutine print_generic(generic)
@@ -3566,77 +3577,13 @@ subroutine print_generic(generic)
line=trim(line)//sep_local
end subroutine print_generic
!===================================================================================================================================
-end function msg_scalar
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,sep)
-
-! ident_15="@(#) M_CLI2 msg_one(3fp) writes a message to a string composed of any standard one dimensional types"
-
-class(*),intent(in) :: generic0(:)
-class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:)
-class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:)
-character(len=*),intent(in),optional :: sep
-character(len=:),allocatable :: sep_local
-character(len=:), allocatable :: msg_one
-character(len=4096) :: line
-integer :: istart
-integer :: increment
- if(present(sep))then
- sep_local=sep
- increment=len(sep_local)+1
- else
- sep_local=' '
- increment=2
- endif
-
- istart=1
- line=' '
- call print_generic(generic0)
- if(present(generic1))call print_generic(generic1)
- if(present(generic2))call print_generic(generic2)
- if(present(generic3))call print_generic(generic3)
- if(present(generic4))call print_generic(generic4)
- if(present(generic5))call print_generic(generic5)
- if(present(generic6))call print_generic(generic6)
- if(present(generic7))call print_generic(generic7)
- if(present(generic8))call print_generic(generic8)
- if(present(generic9))call print_generic(generic9)
- msg_one=trim(line)
-contains
-!===================================================================================================================================
-subroutine print_generic(generic)
-use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
-class(*),intent(in),optional :: generic(:)
-integer :: i
- select type(generic)
- type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic
- type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic
- type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic
- type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic
- type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic
- type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic
- !x! DOES NOT WORK WITH nvfortran: type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic
- !x! DOES NOT WORK WITH ifort: type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic
- type is (logical); write(line(istart:),'("[",*(l1,1x))') generic
- type is (character(len=*))
- write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic))
- type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic
- class default
- call mystop(-22,'unknown type in *print_generic*')
- end select
- istart=len_trim(line)+increment+1
- line=trim(line)//"]"//sep_local
-end subroutine print_generic
-!===================================================================================================================================
-end function msg_one
+end subroutine journal
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function upper(str) result (string)
-! ident_16="@(#) M_CLI2 upper(3f) Changes a string to uppercase"
+! ident_12="@(#) M_CLI2 upper(3f) Changes a string to uppercase"
character(*), intent(in) :: str
character(:),allocatable :: string
@@ -3654,7 +3601,7 @@ end function upper
!===================================================================================================================================
function lower(str) result (string)
-! ident_17="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range"
+! ident_13="@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range"
character(*), intent(In) :: str
character(:),allocatable :: string
@@ -3672,7 +3619,7 @@ end function lower
!===================================================================================================================================
subroutine a2i(chars,valu,ierr)
-! ident_18="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string"
+! ident_14="@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string"
character(len=*),intent(in) :: chars ! input string
integer,intent(out) :: valu ! value read from input string
@@ -3685,7 +3632,7 @@ subroutine a2i(chars,valu,ierr)
if(valu8 <= huge(valu))then
valu=int(valu8)
else
- call journal('sc','*a2i*','- value too large',valu8,'>',ihuge)
+ call journal('*a2i*','- value too large',valu8,'>',ihuge)
valu=huge(valu)
ierr=-1
endif
@@ -3694,7 +3641,7 @@ end subroutine a2i
!----------------------------------------------------------------------------------------------------------------------------------
subroutine a2d(chars,valu,ierr,onerr)
-! ident_19="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string"
+! ident_15="@(#) M_CLI2 a2d(3fp) subroutine returns double value from string"
! 1989,2016 John S. Urban.
!
@@ -3721,7 +3668,7 @@ subroutine a2d(chars,valu,ierr,onerr)
local_chars=unquote(chars)
msg=''
if(len(local_chars) == 0)local_chars=' '
- call substitute(local_chars,',','') ! remove any comma characters
+ local_chars=replace_str(local_chars,',','') ! remove any comma characters
pnd=scan(local_chars,'#:')
if(pnd /= 0)then
write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)'
@@ -3735,15 +3682,15 @@ subroutine a2d(chars,valu,ierr,onerr)
else
select case(local_chars(1:1))
case('z','Z','h','H') ! assume hexadecimal
- frmt='(Z'//i2s(len(local_chars))//')'
+ write(frmt,"('(Z',i0,')')")len(local_chars)
read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
valu=dble(intg)
case('b','B') ! assume binary (base 2)
- frmt='(B'//i2s(len(local_chars))//')'
+ write(frmt,"('(B',i0,')')")len(local_chars)
read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
valu=dble(intg)
case('o','O') ! assume octal
- frmt='(O'//i2s(len(local_chars))//')'
+ write(frmt,"('(O',i0,')')")len(local_chars)
read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg
valu=dble(intg)
case default
@@ -3765,9 +3712,9 @@ subroutine a2d(chars,valu,ierr,onerr)
read(nan_string,'(f3.3)')valu
endif
if(local_chars /= 'eod')then ! print warning message except for special value "eod"
- call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']')
+ call journal('*a2d* - cannot produce number from string ['//trim(chars)//']')
if(msg /= '')then
- call journal('sc','*a2d* - ['//trim(msg)//']')
+ call journal('*a2d* - ['//trim(msg)//']')
endif
endif
endif
@@ -3918,7 +3865,7 @@ end subroutine a2d
subroutine split(input_line,array,delimiters,order,nulls)
!-----------------------------------------------------------------------------------------------------------------------------------
-! ident_20="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array"
+! ident_16="@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array"
! John S. Urban
!-----------------------------------------------------------------------------------------------------------------------------------
@@ -4032,7 +3979,7 @@ subroutine split(input_line,array,delimiters,order,nulls)
endif
enddo
!-----------------------------------------------------------------------------------------------------------------------------------
- end subroutine split
+end subroutine split
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
@@ -4044,16 +3991,15 @@ end subroutine split
!!
!!##SYNOPSIS
!!
-!! function replace_str(targetline[,old,new|cmd],range,ierr) result (newline)
+!! function replace_str(targetline,old,new,range,ierr) result (newline)
!!
-!! character(len=*) :: targetline
-!! character(len=*),intent(in),optional :: old
-!! character(len=*),intent(in),optional :: new
-!! character(len=*),intent(in),optional :: cmd
-!! integer,intent(in),optional :: range(2)
-!! integer,intent(out),optional :: ierr
-!! logical,intent(in),optional :: clip
-!! character(len=:),allocatable :: newline
+!! character(len=*) :: targetline
+!! character(len=*),intent(in) :: old
+!! character(len=*),intent(in) :: new
+!! integer,intent(in),optional :: range(2)
+!! integer,intent(out),optional :: ierr
+!! logical,intent(in),optional :: clip
+!! character(len=:),allocatable :: newline
!!##DESCRIPTION
!! Globally replace one substring for another in string.
!! Either CMD or OLD and NEW must be specified.
@@ -4062,9 +4008,6 @@ end subroutine split
!! targetline input line to be changed
!! old old substring to replace
!! new new substring
-!! cmd alternate way to specify old and new string, in
-!! the form c/old/new/; where "/" can be any character
-!! not in "old" or "new"
!! range if present, only change range(1) to range(2) of
!! occurrences of old string
!! ierr error code. If ier = -1 bad directive, >= 0 then
@@ -4092,11 +4035,11 @@ end subroutine split
!! ! a null new string deletes occurrences of the old substring
!! call testit('i','', 'BEFORE:THs s THe nput strng')
!!
-!! write(*,*)'Examples of the use of RANGE='
-!!
!! targetline=replace_str('a b ab baaa aaaa','a','A')
!! write(*,*)'replace a with A ['//targetline//']'
!!
+!! write(*,*)'Examples of the use of RANGE='
+!!
!! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5])
!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']'
!!
@@ -4141,8 +4084,8 @@ end subroutine split
!! GOT [BEFORE:THs s THe nput strng]
!! EXPECTED[BEFORE:THs s THe nput strng]
!! TEST [ T ]
-!! Examples of the use of RANGE=
!! replace a with A [A b Ab bAAA AAAA]
+!! Examples of the use of RANGE=
!! replace a with A instances 3 to 5 [a b ab bAAA aaaa]
!! replace a with null instances 3 to 5 [a b ab b aaaa]
!! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC
@@ -4152,101 +4095,40 @@ end subroutine split
!! John S. Urban
!!##LICENSE
!! Public Domain
-subroutine crack_cmd(cmd,old,new,ierr)
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=*),intent(in) :: cmd
-character(len=:),allocatable,intent(out) :: old,new ! scratch string buffers
-integer :: ierr
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=1) :: delimiters
-integer :: itoken
-integer,parameter :: id=2 ! expected location of delimiter
-logical :: ifok
-integer :: lmax ! length of target string
-integer :: start_token,end_token
-!-----------------------------------------------------------------------------------------------------------------------------------
- ierr=0
- old=''
- new=''
- lmax=len_trim(cmd) ! significant length of change directive
-
- if(lmax >= 4)then ! strtok ignores blank tokens so look for special case where first token is really null
- delimiters=cmd(id:id) ! find delimiter in expected location
- itoken=0 ! initialize strtok(3f) procedure
-
- if(strtok(cmd(id:),itoken,start_token,end_token,delimiters)) then ! find OLD string
- old=cmd(start_token+id-1:end_token+id-1)
- else
- old=''
- endif
-
- if(cmd(id:id) == cmd(id+1:id+1))then
- new=old
- old=''
- else ! normal case
- ifok=strtok(cmd(id:),itoken,start_token,end_token,delimiters) ! find NEW string
- if(end_token == (len(cmd)-id+1) )end_token=len_trim(cmd(id:)) ! if missing ending delimiter
- new=cmd(start_token+id-1:min(end_token+id-1,lmax))
- endif
- else ! command was two or less characters
- ierr=-1
- call journal('sc','*crack_cmd* incorrect change directive -too short')
- endif
-
-end subroutine crack_cmd
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
-function replace_str(targetline,old,new,ierr,cmd,range) result (newline)
+function replace_str(targetline,old,new,ierr,range) result (newline)
-! ident_21="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string"
+! ident_17="@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string"
!-----------------------------------------------------------------------------------------------------------------------------------
! parameters
character(len=*),intent(in) :: targetline ! input line to be changed
-character(len=*),intent(in),optional :: old ! old substring to replace
-character(len=*),intent(in),optional :: new ! new substring
+character(len=*),intent(in) :: old ! old substring to replace
+character(len=*),intent(in) :: new ! new substring
integer,intent(out),optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made
-character(len=*),intent(in),optional :: cmd ! contains the instructions changing the string
integer,intent(in),optional :: range(2) ! start and end of which changes to make
!-----------------------------------------------------------------------------------------------------------------------------------
! returns
character(len=:),allocatable :: newline ! output string buffer
!-----------------------------------------------------------------------------------------------------------------------------------
! local
-character(len=:),allocatable :: new_local, old_local
-integer :: icount,ichange,ier2
-integer :: original_input_length
-integer :: len_old, len_new
-integer :: ladd
-integer :: left_margin, right_margin
-integer :: ind
-integer :: ic
-integer :: iichar
-integer :: range_local(2)
-!-----------------------------------------------------------------------------------------------------------------------------------
-! get old_local and new_local from cmd or old and new
- if(present(cmd))then
- call crack_cmd(cmd,old_local,new_local,ier2)
- if(ier2 /= 0)then
- newline=targetline ! if no changes are made return original string on error
- if(present(ierr))ierr=ier2
- return
- endif
- elseif(present(old).and.present(new))then
- old_local=old
- new_local=new
- else
- newline=targetline ! if no changes are made return original string on error
- call journal('sc','*replace_str* must specify OLD and NEW or CMD')
- return
- endif
+integer :: icount,ichange
+integer :: original_input_length
+integer :: len_old, len_new
+integer :: ladd
+integer :: left_margin, right_margin
+integer :: ind
+integer :: ic
+integer :: iichar
+integer :: range_local(2)
!-----------------------------------------------------------------------------------------------------------------------------------
icount=0 ! initialize error flag/change count
ichange=0 ! initialize error flag/change count
original_input_length=len_trim(targetline) ! get non-blank length of input line
- len_old=len(old_local) ! length of old substring to be replaced
- len_new=len(new_local) ! length of new substring to replace old substring
+ len_old=len(old) ! length of old substring to be replaced
+ len_new=len(new) ! length of new substring to replace old substring
left_margin=1 ! left_margin is left margin of window to change
right_margin=len(targetline) ! right_margin is right margin of window to change
newline='' ! begin with a blank line as output string
@@ -4260,7 +4142,7 @@ function replace_str(targetline,old,new,ierr,cmd,range) result (newline)
if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin)
iichar=len_new + original_input_length
if(len_new > 0)then
- newline=new_local(:len_new)//targetline(left_margin:original_input_length)
+ newline=new(:len_new)//targetline(left_margin:original_input_length)
else
newline=targetline(left_margin:original_input_length)
endif
@@ -4272,7 +4154,7 @@ function replace_str(targetline,old,new,ierr,cmd,range) result (newline)
iichar=left_margin ! place to put characters into output string
ic=left_margin ! place looking at in input string
loop: do
- ind=index(targetline(ic:),old_local(:len_old))+ic-1 ! try finding start of OLD in remaining part of input in change window
+ ind=index(targetline(ic:),old(:len_old))+ic-1 ! try finding start of OLD in remaining part of input in change window
if(ind == ic-1.or.ind > right_margin)then ! did not find old string or found old string past edit window
exit loop ! no more changes left to make
endif
@@ -4285,12 +4167,12 @@ function replace_str(targetline,old,new,ierr,cmd,range) result (newline)
if(icount >= range_local(1).and.icount <= range_local(2))then ! check if this is an instance to change or keep
ichange=ichange+1
if(len_new /= 0)then ! put in new string
- newline=newline(:iichar-1)//new_local(:len_new)
+ newline=newline(:iichar-1)//new(:len_new)
iichar=iichar+len_new
endif
else
if(len_old /= 0)then ! put in copy of old string
- newline=newline(:iichar-1)//old_local(:len_old)
+ newline=newline(:iichar-1)//old(:len_old)
iichar=iichar+len_old
endif
endif
@@ -4392,28 +4274,35 @@ function quote(str,mode,clip) result (quoted_str)
character(len=1),parameter :: double_quote = '"'
character(len=20) :: local_mode
-!-----------------------------------------------------------------------------------------------------------------------------------
- local_mode=merge_str(mode,'DOUBLE',present(mode))
+
+ if(present(mode))then
+ local_mode=mode
+ else
+ local_mode='DOUBLE'
+ endif
+
if(present(clip))then
clip_local=clip
else
clip_local=.false.
endif
+
if(clip_local)then
quoted_str=adjustl(str)
else
quoted_str=str
endif
+
select case(lower(local_mode))
case('double')
quoted_str=double_quote//trim(replace_str(quoted_str,'"','""'))//double_quote
case('escape')
quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote
case default
- call journal('sc','*quote* ERROR: unknown quote mode ',local_mode)
+ call journal('*quote* ERROR: unknown quote mode ',local_mode)
quoted_str=str
end select
-!-----------------------------------------------------------------------------------------------------------------------------------
+
end function quote
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
@@ -4561,112 +4450,6 @@ end function unquote
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
-function i2s(ivalue,fmt) result(outstr)
-
-! ident_22="@(#) M_CLI2 i2s(3fp) private function returns string given integer value"
-
-integer,intent(in) :: ivalue ! input value to convert to a string
-character(len=*),intent(in),optional :: fmt
-character(len=:),allocatable :: outstr ! output string to generate
-character(len=80) :: string
- if(present(fmt))then
- call value_to_string(ivalue,string,fmt=fmt)
- else
- call value_to_string(ivalue,string)
- endif
- outstr=trim(string)
-end function i2s
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! merge_str(3f) - [M_CLI2:LENGTH] pads strings to same length and then
-!! calls MERGE(3f)
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function merge_str(str1,str2,expr) result(strout)
-!!
-!! character(len=*),intent(in),optional :: str1
-!! character(len=*),intent(in),optional :: str2
-!! logical,intent(in) :: expr
-!! character(len=:),allocatable :: strout
-!!##DESCRIPTION
-!! merge_str(3f) pads the shorter of str1 and str2 to the longest length
-!! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr).
-!! It trims trailing spaces off the result and returns the trimmed
-!! string. This makes it easier to call MERGE(3f) with strings, as
-!! MERGE(3f) requires the strings to be the same length.
-!!
-!! NOTE: STR1 and STR2 are always required even though declared optional.
-!! this is so the call "STR_MERGE(A,B,present(A))" is a valid call.
-!! The parameters STR1 and STR2 when they are optional parameters
-!! can be passed to a procedure if the options are optional on the
-!! called procedure.
-!!
-!!##OPTIONS
-!! STR1 string to return if the logical expression EXPR is true
-!! STR2 string to return if the logical expression EXPR is false
-!! EXPR logical expression to evaluate to determine whether to return
-!! STR1 when true, and STR2 when false.
-!!##RESULT
-!! MERGE_STR a trimmed string is returned that is otherwise the value
-!! of STR1 or STR2, depending on the logical expression EXPR.
-!!
-!!##EXAMPLES
-!!
-!! Sample Program:
-!!
-!! program demo_merge_str
-!! use M_CLI2, only : merge_str
-!! implicit none
-!! character(len=:), allocatable :: answer
-!! answer=merge_str('first string', 'second string is longer',10 == 10)
-!! write(*,'("[",a,"]")') answer
-!! answer=merge_str('first string', 'second string is longer',10 /= 10)
-!! write(*,'("[",a,"]")') answer
-!! end program demo_merge_str
-!!
-!! Expected output
-!!
-!! [first string]
-!! [second string is longer]
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function merge_str(str1,str2,expr) result(strout)
-! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length
-! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces
-
-! ident_23="@(#) M_CLI2 merge_str(3f) pads first and second arguments to MERGE(3f) to same length"
-
-character(len=*),intent(in),optional :: str1
-character(len=*),intent(in),optional :: str2
-character(len=:),allocatable :: str1_local
-character(len=:),allocatable :: str2_local
-logical,intent(in) :: expr
-character(len=:),allocatable :: strout
-integer :: big
- if(present(str2))then
- str2_local=str2
- else
- str2_local=''
- endif
- if(present(str1))then
- str1_local=str1
- else
- str1_local=''
- endif
- big=max( len(str1_local), len(str2_local) )
- ! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning ''
- strout=trim(merge(lenset(str1_local,big),lenset(str2_local,big),expr))
-end function merge_str
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
!>
!!##NAME
!!
@@ -4743,7 +4526,7 @@ end function merge_str
!! Public Domain
logical function decodebase(string,basein,out_baseten)
-! ident_24="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number"
+! ident_18="@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number"
character(len=*),intent(in) :: string
integer,intent(in) :: basein
@@ -4819,503 +4602,6 @@ end function decodebase
!===================================================================================================================================
!>
!!##NAME
-!! lenset(3f) - [M_CLI2:LENGTH] return string trimmed or padded to
-!! specified length
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! function lenset(str,length) result(strout)
-!!
-!! character(len=*) :: str
-!! character(len=length) :: strout
-!! integer,intent(in) :: length
-!!##DESCRIPTION
-!! lenset(3f) truncates a string or pads it with spaces to the specified
-!! length.
-!!##OPTIONS
-!! str input string
-!! length output string length
-!!##RESULTS
-!! strout output string
-!!##EXAMPLE
-!!
-!! Sample Program:
-!!
-!! program demo_lenset
-!! use M_CLI2, only : lenset
-!! implicit none
-!! character(len=10) :: string='abcdefghij'
-!! character(len=:),allocatable :: answer
-!! answer=lenset(string,5)
-!! write(*,'("[",a,"]")') answer
-!! answer=lenset(string,20)
-!! write(*,'("[",a,"]")') answer
-!! end program demo_lenset
-!!
-!! Expected output:
-!!
-!! [abcde]
-!! [abcdefghij ]
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-function lenset(line,length) result(strout)
-
-! ident_25="@(#) M_CLI2 lenset(3f) return string trimmed or padded to specified length"
-
-character(len=*),intent(in) :: line
-integer,intent(in) :: length
-character(len=length) :: strout
- strout=line
-end function lenset
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! value_to_string(3f) - [M_CLI2:NUMERIC] return numeric string from
-!! a numeric value
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine value_to_string(value,chars[,iilen,ierr,fmt,trimz])
-!!
-!! character(len=*) :: chars ! minimum of 23 characters required
-!! !--------
-!! ! VALUE may be any one of the following types:
-!! doubleprecision,intent(in) :: value
-!! real,intent(in) :: value
-!! integer,intent(in) :: value
-!! logical,intent(in) :: value
-!! !--------
-!! character(len=*),intent(out) :: chars
-!! integer,intent(out),optional :: iilen
-!! integer,optional :: ierr
-!! character(len=*),intent(in),optional :: fmt
-!! logical,intent(in) :: trimz
-!!
-!!##DESCRIPTION
-!! value_to_string(3f) returns a numeric representation of a numeric
-!! value in a string given a numeric value of type REAL, DOUBLEPRECISION,
-!! INTEGER or LOGICAL. It creates the string using internal writes. It
-!! then removes trailing zeros from non-zero values, and left-justifies
-!! the string.
-!!
-!!##OPTIONS
-!! VALUE input value to be converted to a string
-!! FMT You may specify a specific format that produces a string
-!! up to the length of CHARS; optional.
-!! TRIMZ If a format is supplied the default is not to try to trim
-!! trailing zeros. Set TRIMZ to .true. to trim zeros from a
-!! string assumed to represent a simple numeric value.
-!!
-!!##RETURNS
-!! CHARS returned string representing input value, must be at least
-!! 23 characters long; or what is required by optional FMT
-!! if longer.
-!! IILEN position of last non-blank character in returned string;
-!! optional.
-!! IERR If not zero, error occurred; optional.
-!!##EXAMPLE
-!!
-!! Sample program:
-!!
-!! program demo_value_to_string
-!! use M_CLI2, only: value_to_string
-!! implicit none
-!! character(len=80) :: string
-!! integer :: iilen
-!! call value_to_string(3.0/4.0,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(3.0/4.0,string,iilen,fmt='')
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(3.0/4.0,string,iilen,fmt='("THE VALUE IS ",g0)')
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(1234,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! call value_to_string(1.0d0/3.0d0,string,iilen)
-!! write(*,*) 'The value is [',string(:iilen),']'
-!!
-!! end program demo_value_to_string
-!!
-!! Expected output
-!!
-!! The value is [0.75]
-!! The value is [ 0.7500000000]
-!! The value is [THE VALUE IS .750000000]
-!! The value is [1234]
-!! The value is [0.33333333333333331]
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine value_to_string(gval,chars,length,err,fmt,trimz)
-
-! ident_26="@(#) M_CLI2 value_to_string(3fp) subroutine returns a string from a value"
-
-class(*),intent(in) :: gval
-character(len=*),intent(out) :: chars
-integer,intent(out),optional :: length
-integer,optional :: err
-integer :: err_local
-character(len=*),optional,intent(in) :: fmt ! format to write value with
-logical,intent(in),optional :: trimz
-character(len=:),allocatable :: fmt_local
-character(len=1024) :: msg
-
-! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL)
-
- if (present(fmt)) then
- select type(gval)
- type is (integer)
- fmt_local='(i0)'
- if(fmt /= '') fmt_local=fmt
- write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
- type is (real)
- fmt_local='(bz,g23.10e3)'
- fmt_local='(bz,g0.8)'
- if(fmt /= '') fmt_local=fmt
- write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
- type is (doubleprecision)
- fmt_local='(bz,g0)'
- if(fmt /= '') fmt_local=fmt
- write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
- type is (logical)
- fmt_local='(l1)'
- if(fmt /= '') fmt_local=fmt
- write(chars,fmt_local,iostat=err_local,iomsg=msg)gval
- class default
- call journal('sc','*value_to_string* UNKNOWN TYPE')
- chars=' '
- end select
- if(fmt == '') then
- chars=adjustl(chars)
- call trimzeros_(chars)
- endif
- else ! no explicit format option present
- err_local=-1
- select type(gval)
- type is (integer)
- write(chars,*,iostat=err_local,iomsg=msg)gval
- type is (real)
- write(chars,*,iostat=err_local,iomsg=msg)gval
- type is (doubleprecision)
- write(chars,*,iostat=err_local,iomsg=msg)gval
- type is (logical)
- write(chars,*,iostat=err_local,iomsg=msg)gval
- class default
- chars=''
- end select
- chars=adjustl(chars)
- if(index(chars,'.') /= 0) call trimzeros_(chars)
- endif
- if(present(trimz))then
- if(trimz)then
- chars=adjustl(chars)
- call trimzeros_(chars)
- endif
- endif
-
- if(present(length)) then
- length=len_trim(chars)
- endif
-
- if(present(err)) then
- err=err_local
- elseif(err_local /= 0)then
- !-! cannot currently do I/O from a function being called from I/O
- !-!write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']'
- chars=chars//' *value_to_string* WARNING:['//trim(msg)//']'
- endif
-
-end subroutine value_to_string
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! trimzeros_(3fp) - [M_CLI2:NUMERIC] Delete trailing zeros from numeric
-!! `decimal string
-!! (LICENSE:PD)
-!!##SYNOPSIS
-!!
-!! subroutine trimzeros_(str)
-!!
-!! character(len=*) :: str
-!!##DESCRIPTION
-!! TRIMZEROS_(3f) deletes trailing zeros from a string representing a
-!! number. If the resulting string would end in a decimal point, one
-!! trailing zero is added.
-!!##OPTIONS
-!! str input string will be assumed to be a numeric value and have
-!! trailing zeros removed
-!!##EXAMPLES
-!!
-!! Sample program:
-!!
-!! program demo_trimzeros_
-!! use M_CLI2, only : trimzeros_
-!! character(len=:),allocatable :: string
-!! write(*,*)trimzeros_('123.450000000000')
-!! write(*,*)trimzeros_('12345')
-!! write(*,*)trimzeros_('12345.')
-!! write(*,*)trimzeros_('12345.00e3')
-!! end program demo_trimzeros_
-!!
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine trimzeros_(string)
-
-! ident_27="@(#) M_CLI2 trimzeros_(3fp) Delete trailing zeros from numeric decimal string"
-
-! if zero needs added at end assumes input string has room
-character(len=*) :: string
-character(len=len(string)+2) :: str
-character(len=len(string)) :: expo ! the exponent string if present
-integer :: ipos ! where exponent letter appears if present
-integer :: i, ii
- str=string ! working copy of string
- ipos=scan(str,'eEdD') ! find end of real number if string uses exponent notation
- if(ipos>0) then ! letter was found
- expo=str(ipos:) ! keep exponent string so it can be added back as a suffix
- str=str(1:ipos-1) ! just the real part, exponent removed will not have trailing zeros removed
- endif
- if(index(str,'.') == 0)then ! if no decimal character in original string add one to end of string
- ii=len_trim(str)
- str(ii+1:ii+1)='.' ! add decimal to end of string
- endif
- do i=len_trim(str),1,-1 ! scanning from end find a non-zero character
- select case(str(i:i))
- case('0') ! found a trailing zero so keep trimming
- cycle
- case('.') ! found a decimal character at end of remaining string
- if(i <= 1)then
- str='0'
- else
- str=str(1:i-1)
- endif
- exit
- case default
- str=str(1:i) ! found a non-zero character so trim string and exit
- exit
- end select
- end do
- if(ipos>0)then ! if originally had an exponent place it back on
- string=trim(str)//trim(expo)
- else
- string=str
- endif
-end subroutine trimzeros_
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
-!===================================================================================================================================
-!>
-!!##NAME
-!! substitute(3f) - [M_CLI2:EDITING] subroutine globally substitutes
-!! one substring for another in string
-!! (LICENSE:PD)
-!!
-!!##SYNOPSIS
-!!
-!! subroutine substitute(targetline,old,new,ierr,start,end)
-!!
-!! character(len=*) :: targetline
-!! character(len=*),intent(in) :: old
-!! character(len=*),intent(in) :: new
-!! integer,intent(out),optional :: ierr
-!! integer,intent(in),optional :: start
-!! integer,intent(in),optional :: end
-!!##DESCRIPTION
-!! Globally substitute one substring for another in string.
-!!
-!!##OPTIONS
-!! TARGETLINE input line to be changed. Must be long enough to
-!! hold altered output.
-!! OLD substring to find and replace
-!! NEW replacement for OLD substring
-!! IERR error code. If IER = -1 bad directive, >= 0 then
-!! count of changes made.
-!! START sets the left margin to be scanned for OLD in
-!! TARGETLINE.
-!! END sets the right margin to be scanned for OLD in
-!! TARGETLINE.
-!!
-!!##EXAMPLES
-!!
-!! Sample Program:
-!!
-!! program demo_substitute
-!! use M_CLI2, only : substitute
-!! implicit none
-!! ! must be long enough to hold changed line
-!! character(len=80) :: targetline
-!!
-!! targetline='this is the input string'
-!! write(*,*)'ORIGINAL : '//trim(targetline)
-!!
-!! ! changes the input to 'THis is THe input string'
-!! call substitute(targetline,'th','TH')
-!! write(*,*)'th => TH : '//trim(targetline)
-!!
-!! ! a null old substring means "at beginning of line"
-!! ! changes the input to 'BEFORE:this is the input string'
-!! call substitute(targetline,'','BEFORE:')
-!! write(*,*)'"" => BEFORE: '//trim(targetline)
-!!
-!! ! a null new string deletes occurrences of the old substring
-!! ! changes the input to 'ths s the nput strng'
-!! call substitute(targetline,'i','')
-!! write(*,*)'i => "" : '//trim(targetline)
-!!
-!! end program demo_substitute
-!!
-!! Expected output
-!!
-!! ORIGINAL : this is the input string
-!! th => TH : THis is THe input string
-!! "" => BEFORE: BEFORE:THis is THe input string
-!! i => "" : BEFORE:THs s THe nput strng
-!!##AUTHOR
-!! John S. Urban
-!!##LICENSE
-!! Public Domain
-subroutine substitute(targetline,old,new,ierr,start,end)
-
-! ident_28="@(#) M_CLI2 substitute(3f) Globally substitute one substring for another in string"
-
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=*) :: targetline ! input line to be changed
-character(len=*),intent(in) :: old ! old substring to replace
-character(len=*),intent(in) :: new ! new substring
-integer,intent(out),optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made
-integer,intent(in),optional :: start ! start sets the left margin
-integer,intent(in),optional :: end ! end sets the right margin
-!-----------------------------------------------------------------------------------------------------------------------------------
-character(len=len(targetline)) :: dum1 ! scratch string buffers
-integer :: ml, mr, ier1
-integer :: maxlengthout ! MAXIMUM LENGTH ALLOWED FOR NEW STRING
-integer :: original_input_length
-integer :: len_old, len_new
-integer :: ladd
-integer :: ir
-integer :: ind
-integer :: il
-integer :: id
-integer :: ic
-integer :: iichar
-!-----------------------------------------------------------------------------------------------------------------------------------
- if (present(start)) then ! optional starting column
- ml=start
- else
- ml=1
- endif
- if (present(end)) then ! optional ending column
- mr=end
- else
- mr=len(targetline)
- endif
-!-----------------------------------------------------------------------------------------------------------------------------------
- ier1=0 ! initialize error flag/change count
- maxlengthout=len(targetline) ! max length of output string
- original_input_length=len_trim(targetline) ! get non-blank length of input line
- dum1(:)=' ' ! initialize string to build output in
- id=mr-ml ! check for window option !-! change to optional parameter(s)
-!-----------------------------------------------------------------------------------------------------------------------------------
- len_old=len(old) ! length of old substring to be replaced
- len_new=len(new) ! length of new substring to replace old substring
- if(id <= 0)then ! no window so change entire input string
- il=1 ! il is left margin of window to change
- ir=maxlengthout ! ir is right margin of window to change
- dum1(:)=' ' ! begin with a blank line
- else ! if window is set
- il=ml ! use left margin
- ir=min0(mr,maxlengthout) ! use right margin or rightmost
- dum1=targetline(:il-1) ! begin with what's below margin
- endif ! end of window settings
-!-----------------------------------------------------------------------------------------------------------------------------------
- if(len_old == 0)then ! c//new/ means insert new at beginning of line (or left margin)
- iichar=len_new + original_input_length
- if(iichar > maxlengthout)then
- call journal('sc','*substitute* new line will be too long')
- ier1=-1
- if (present(ierr))ierr=ier1
- return
- endif
- if(len_new > 0)then
- dum1(il:)=new(:len_new)//targetline(il:original_input_length)
- else
- dum1(il:)=targetline(il:original_input_length)
- endif
- targetline(1:maxlengthout)=dum1(:maxlengthout)
- ier1=1 ! made one change. actually, c/// should maybe return 0
- if(present(ierr))ierr=ier1
- return
- endif
-!-----------------------------------------------------------------------------------------------------------------------------------
- iichar=il ! place to put characters into output string
- ic=il ! place looking at in input string
- loop: do
- ind=index(targetline(ic:),old(:len_old))+ic-1 ! try to find start of old string in remaining part of input in change window
- if(ind == ic-1.or.ind > ir)then ! did not find old string or found old string past edit window
- exit loop ! no more changes left to make
- endif
- ier1=ier1+1 ! found an old string to change, so increment count of changes
- if(ind > ic)then ! if found old string past at current position in input string copy unchanged
- ladd=ind-ic ! find length of character range to copy as-is from input to output
- if(iichar-1+ladd > maxlengthout)then
- ier1=-1
- exit loop
- endif
- dum1(iichar:)=targetline(ic:ind-1)
- iichar=iichar+ladd
- endif
- if(iichar-1+len_new > maxlengthout)then
- ier1=-2
- exit loop
- endif
- if(len_new /= 0)then
- dum1(iichar:)=new(:len_new)
- iichar=iichar+len_new
- endif
- ic=ind+len_old
- enddo loop
-!-----------------------------------------------------------------------------------------------------------------------------------
- select case (ier1)
- case (:-1)
- call journal('sc','*substitute* new line will be too long')
- case (0) ! there were no changes made to the window
- case default
- ladd=original_input_length-ic
- if(iichar+ladd > maxlengthout)then
- call journal('sc','*substitute* new line will be too long')
- ier1=-1
- if(present(ierr))ierr=ier1
- return
- endif
- if(ic < len(targetline))then
- dum1(iichar:)=targetline(ic:max(ic,original_input_length))
- endif
- targetline=dum1(:maxlengthout)
- end select
- if(present(ierr))ierr=ier1
-!-----------------------------------------------------------------------------------------------------------------------------------
-end subroutine substitute
-!===================================================================================================================================
-!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
-!===================================================================================================================================
-!>
-!!##NAME
!! locate_(3f) - [M_CLI2] finds the index where a string is found or
!! should be in a sorted array
!! (LICENSE:PD)
@@ -5378,15 +4664,15 @@ end subroutine substitute
!! ! make sure sorted in descending order
!! call sort_shell(arr,order='d')
!!
-!! call update(arr,'b')
-!! call update(arr,'[')
-!! call update(arr,'c')
-!! call update(arr,'ZZ')
-!! call update(arr,'ZZZZ')
-!! call update(arr,'z')
+!! call update_dic(arr,'b')
+!! call update_dic(arr,'[')
+!! call update_dic(arr,'c')
+!! call update_dic(arr,'ZZ')
+!! call update_dic(arr,'ZZZZ')
+!! call update_dic(arr,'z')
!!
!! contains
-!! subroutine update(arr,string)
+!! subroutine update_dic(arr,string)
!! character(len=:),intent(in),allocatable :: arr(:)
!! character(len=*),intent(in) :: string
!! integer :: place, plus, ii, end
@@ -5414,7 +4700,7 @@ end subroutine substitute
!! ! show array
!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
!! endif
-!! end subroutine update
+!! end subroutine update_dic
!! end program demo_locate
!!
!! Results:
@@ -5437,7 +4723,7 @@ end subroutine substitute
!! Public Domain
subroutine locate_c(list,value,place,ier,errmsg)
-! ident_29="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed"
+! ident_19="@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed"
character(len=*),intent(in) :: value
integer,intent(out) :: place
@@ -5575,7 +4861,7 @@ end subroutine locate_c
!! Public Domain
subroutine remove_c(list,place)
-! ident_30="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position"
+! ident_20="@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position"
character(len=:),allocatable :: list(:)
integer,intent(in) :: place
@@ -5594,7 +4880,7 @@ subroutine remove_c(list,place)
end subroutine remove_c
subroutine remove_l(list,place)
-! ident_31="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position"
+! ident_21="@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position"
logical,allocatable :: list(:)
integer,intent(in) :: place
@@ -5614,7 +4900,7 @@ subroutine remove_l(list,place)
end subroutine remove_l
subroutine remove_i(list,place)
-! ident_32="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position"
+! ident_22="@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position"
integer,allocatable :: list(:)
integer,intent(in) :: place
integer :: end
@@ -5645,7 +4931,7 @@ end subroutine remove_i
!!
!! character(len=*)|doubleprecision|real|integer,intent(in) :: value
!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:)
-!! integer, intent(out) :: PLACE
+!! integer, intent(out) :: place
!!
!!##DESCRIPTION
!!
@@ -5681,12 +4967,12 @@ end subroutine remove_i
!! character(len=:),allocatable :: values(:)
!! integer :: i
!! integer :: place
-!! call update('b','value of b')
-!! call update('a','value of a')
-!! call update('c','value of c')
-!! call update('c','value of c again')
-!! call update('d','value of d')
-!! call update('a','value of a again')
+!! call update_dic('b','value of b')
+!! call update_dic('a','value of a')
+!! call update_dic('c','value of c')
+!! call update_dic('c','value of c again')
+!! call update_dic('d','value of d')
+!! call update_dic('a','value of a again')
!! ! show array
!! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords))
!!
@@ -5698,7 +4984,7 @@ end subroutine remove_i
!! endif
!!
!! contains
-!! subroutine update(key,val)
+!! subroutine update_dic(key,val)
!! character(len=*),intent(in) :: key
!! character(len=*),intent(in) :: val
!! integer :: place
@@ -5713,8 +4999,8 @@ end subroutine remove_i
!! call replace_(values,val,place)
!! endif
!!
-!! end subroutine update
-!! end program demo_replace_
+!! end subroutine update_dic
+!! end program demo_replace
!!
!! Expected output
!!
@@ -5729,7 +5015,7 @@ end subroutine remove_i
!! Public Domain
subroutine replace_c(list,value,place)
-! ident_33="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position"
+! ident_23="@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position"
character(len=*),intent(in) :: value
character(len=:),allocatable :: list(:)
@@ -5756,7 +5042,7 @@ subroutine replace_c(list,value,place)
end subroutine replace_c
subroutine replace_l(list,value,place)
-! ident_34="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position"
+! ident_24="@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position"
logical,allocatable :: list(:)
logical,intent(in) :: value
@@ -5776,7 +5062,7 @@ subroutine replace_l(list,value,place)
end subroutine replace_l
subroutine replace_i(list,value,place)
-! ident_35="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position"
+! ident_25="@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position"
integer,intent(in) :: value
integer,allocatable :: list(:)
@@ -5839,17 +5125,17 @@ end subroutine replace_i
!! ! make sure sorted in descending order
!! call sort_shell(arr,order='d')
!! ! add or replace values
-!! call update(arr,'b')
-!! call update(arr,'[')
-!! call update(arr,'c')
-!! call update(arr,'ZZ')
-!! call update(arr,'ZZZ')
-!! call update(arr,'ZZZZ')
-!! call update(arr,'')
-!! call update(arr,'z')
+!! call update_dic(arr,'b')
+!! call update_dic(arr,'[')
+!! call update_dic(arr,'c')
+!! call update_dic(arr,'ZZ')
+!! call update_dic(arr,'ZZZ')
+!! call update_dic(arr,'ZZZZ')
+!! call update_dic(arr,'')
+!! call update_dic(arr,'z')
!!
!! contains
-!! subroutine update(arr,string)
+!! subroutine update_dic(arr,string)
!! character(len=:),allocatable :: arr(:)
!! character(len=*) :: string
!! integer :: place, end
@@ -5865,8 +5151,8 @@ end subroutine replace_i
!! end=size(arr)
!! write(*,'("array is now SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end)
!!
-!! end subroutine update
-!! end program demo_insert_
+!! end subroutine update_dic
+!! end program demo_insert
!!
!! Results:
!!
@@ -5883,7 +5169,7 @@ end subroutine replace_i
!! Public Domain
subroutine insert_c(list,value,place)
-! ident_36="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position"
+! ident_26="@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position"
character(len=*),intent(in) :: value
character(len=:),allocatable :: list(:)
@@ -5899,12 +5185,12 @@ subroutine insert_c(list,value,place)
ii=max(len_trim(value),len(list),2)
end=size(list)
- if(end == 0)then ! empty array
+ if(end == 0)then ! empty array
list=[character(len=ii) :: value ]
- elseif(place == 1)then ! put in front of array
+ elseif(place == 1)then ! put in front of array
kludge=[character(len=ii) :: value, list]
list=kludge
- elseif(place > end)then ! put at end of array
+ elseif(place > end)then ! put at end of array
kludge=[character(len=ii) :: list, value ]
list=kludge
elseif(place >= 2.and.place <= end)then ! put in middle of array
@@ -5917,7 +5203,7 @@ subroutine insert_c(list,value,place)
end subroutine insert_c
subroutine insert_l(list,value,place)
-! ident_37="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position"
+! ident_27="@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position"
logical,allocatable :: list(:)
logical,intent(in) :: value
@@ -5931,9 +5217,9 @@ subroutine insert_l(list,value,place)
list=[value]
elseif(place == 1)then ! put in front of array
list=[value, list]
- elseif(place > end)then ! put at end of array
+ elseif(place > end)then ! put at end of array
list=[list, value ]
- elseif(place >= 2.and.place <= end)then ! put in middle of array
+ elseif(place >= 2.and.place <= end)then ! put in middle of array
list=[list(:place-1), value,list(place:) ]
else ! index out of range
write(warn,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value
@@ -5942,7 +5228,7 @@ subroutine insert_l(list,value,place)
end subroutine insert_l
subroutine insert_i(list,value,place)
-! ident_38="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position"
+! ident_28="@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position"
integer,allocatable :: list(:)
integer,intent(in) :: value
@@ -5956,9 +5242,9 @@ subroutine insert_i(list,value,place)
list=[value]
elseif(place == 1)then ! put in front of array
list=[value, list]
- elseif(place > end)then ! put at end of array
+ elseif(place > end)then ! put at end of array
list=[list, value ]
- elseif(place >= 2.and.place <= end)then ! put in middle of array
+ elseif(place >= 2.and.place <= end)then ! put in middle of array
list=[list(:place-1), value,list(place:) ]
else ! index out of range
write(warn,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value
@@ -5971,13 +5257,12 @@ end subroutine insert_i
subroutine many_args(n0,g0, n1,g1, n2,g2, n3,g3, n4,g4, n5,g5, n6,g6, n7,g7, n8,g8, n9,g9, &
& na,ga, nb,gb, nc,gc, nd,gd, ne,ge, nf,gf, ng,gg, nh,gh, ni,gi, nj,gj )
-! ident_39="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)"
+! ident_29="@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)"
character(len=*),intent(in) :: n0, n1
-character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj
+character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj
class(*),intent(out) :: g0, g1
-class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9
-class(*),intent(out),optional :: ga, gb, gc, gd, ge, gf, gg, gh, gi, gj
+class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj
call get_generic(n0,g0)
call get_generic(n1,g1)
if( present(n2) .and. present(g2) )call get_generic(n2,g2)
@@ -6098,7 +5383,7 @@ function lg()
case('T','Y',' '); lg(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...)
case('F','N'); lg(i)=.false. ! assume this is false or no
case default
- call journal('sc',"*lg* bad logical expression for element",i,'=',hold)
+ call journal("*lg* bad logical expression for element",i,'=',hold)
end select
enddo
end function lg
@@ -6122,6 +5407,7 @@ end function cg
! sg=unnamed
!end function sg
+!===================================================================================================================================
function sg()
character(len=:),allocatable :: sg(:)
if(allocated(sg))deallocate(sg)
@@ -6140,10 +5426,8 @@ subroutine mystop(sig,msg)
!
integer,intent(in) :: sig
character(len=*),intent(in),optional :: msg
- !x!write(*,*)'MYSTOP:',sig,trim(msg)
if(sig < 0)then
- if(present(msg))call journal('sc',msg)
- !x!stop abs(sig)
+ if(present(msg))call journal(msg)
stop 1
elseif(.not.G_QUIET)then
stop
@@ -6154,7 +5438,6 @@ subroutine mystop(sig,msg)
G_STOP_MESSAGE=''
endif
G_STOP=sig
- !x!write(*,*)'G_STOP:',g_stop,trim(msg)
endif
end subroutine mystop
!===================================================================================================================================
@@ -6162,7 +5445,7 @@ end subroutine mystop
!===================================================================================================================================
function atleast(line,length,pattern) result(strout)
-! ident_40="@(#) M_strings atleast(3f) return string padded to at least specified length"
+! ident_30="@(#) M_strings atleast(3f) return string padded to at least specified length"
character(len=*),intent(in) :: line
integer,intent(in) :: length
@@ -6179,7 +5462,7 @@ end function atleast
!===================================================================================================================================
subroutine locate_key(value,place)
-! ident_41="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed"
+! ident_31="@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed"
character(len=*),intent(in) :: value
integer,intent(out) :: place
@@ -6191,8 +5474,12 @@ subroutine locate_key(value,place)
else
value_local=trim(value)
endif
+ if(G_NOSEPARATOR)then
+ value_local=replace_str(value_local,'-','')
+ value_local=replace_str(value_local,'_','')
+ endif
- if(G_IGNORECASE.and.len(value_local) > 1)value_local=lower(value_local)
+ if(G_IGNORECASE.and.len_trim(value_local) > 1)value_local=lower(value_local)
if(len(value_local) == 1)then
!x!ii=findloc(shorts,value_local,dim=1)
@@ -6226,12 +5513,25 @@ end subroutine locate_key
!!
!!##OPTIONS
!! KEY name of option
-!! o response_file - enable use of response file
-!! o ignorecase - ignore case in long key names
-!! o underdash - treat dash in keyname as an underscore
-!! o strict - allow boolean keys to be bundled, but requires
-!! a single dash prefix be used for short key names and
-!! long names to be prefixed with two dashes.
+!!
+!! The following values are allowed:
+!!
+!! o response_file - enable use of response file
+!!
+!! o ignorecase - ignore case in long key names. So the user
+!! does not have to remember if the option is --IgnoreCase
+!! or --ignorecase or --ignoreCase
+!!
+!! o underdash - treat dash in keyword as an underscore.
+!! So the user should not have to remember if the option is
+!! --ignore_case or --ignore-case.
+!!
+!! o strict - allow Boolean keys to be bundled, but requires
+!! a single dash prefix be used for short key names and
+!! long names must be prefixed with two dashes.
+!!
+!! o lastonly - when multiple keywords occur keep the rightmost
+!! value specified instead of appending the values together.
!!
!! MODE set to .true. to activate the optional mode.
!! Set to .false. to deactivate the mode.
@@ -6249,16 +5549,16 @@ end subroutine locate_key
!! ! enable use of response files
!! call set_mode('response_file')
!! !
-!! ! Any dash in a keyname is treated as an underscore
+!! ! Any dash in a keyword is treated as an underscore
!! call set_mode('underdash')
!! !
-!! ! The case of long keynames are ignored.
+!! ! The case of long keywords are ignored.
!! ! Values and short names remain case-sensitive
!! call set_mode('ignorecase')
!! !
!! ! short single-character boolean keys may be bundled
!! ! but it is required that a single dash is used for
-!! ! short keys and a double dash for long keynames.
+!! ! short keys and a double dash for long keywords.
!! call set_mode('strict')
!! !
!! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
@@ -6280,20 +5580,27 @@ elemental impure subroutine set_mode(key,mode)
character(len=*),intent(in) :: key
logical,intent(in),optional :: mode
logical :: local_mode
+
if(present(mode))then
local_mode=mode
else
local_mode=.true.
endif
+
select case(lower(key))
case('response_file','response file'); CLI_RESPONSE_FILE=local_mode
case('debug'); G_DEBUG=local_mode
case('ignorecase'); G_IGNORECASE=local_mode
case('underdash'); G_UNDERDASH=local_mode
+ case('noseparator'); G_NOSEPARATOR=local_mode
case('strict'); G_STRICT=local_mode
+ case('lastonly'); G_APPEND=.not.local_mode
case default
- call journal('sc','set_mode* unknown key name ',key)
+ call journal('*set_mode* unknown key name ',key)
end select
+
+ if(G_DEBUG)write(*,gen)'EXPAND_RESPONSE:END'
+
end subroutine set_mode
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
diff --git a/docs/fpm-ford/src/demo1.f90 b/docs/fpm-ford/src/demo1.f90
index ac0f8f3e..2ffe9add 100755
--- a/docs/fpm-ford/src/demo1.f90
+++ b/docs/fpm-ford/src/demo1.f90
@@ -1,14 +1,16 @@
program demo1
!! @(#) using the convenience functions
- use M_CLI2, only : set_args, get_args_fixed_size, set_mode
- use M_CLI2, only : dget, iget, lget, rget, sget, cget ! for scalars
- use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets ! for allocatable arrays
- implicit none
+use M_CLI2, only : set_args, get_args_fixed_size, set_mode
+use M_CLI2, only : dget, iget, lget, rget, sget, cget ! for scalars
+use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets ! for allocatable arrays
+implicit none
!! DECLARE "ARGS"
- real :: x, y, z, point(3)
- character(len=:), allocatable :: title, anytitle
- logical :: l, lupper
+real :: x, y, z, point(3)
+character(len=:), allocatable :: title, anytitle
+logical :: l, lupper
+
+ print *,'demo1: using the convenience functions'
call set_mode('response_file')
!! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES
diff --git a/docs/fpm-ford/src/demo10.f90 b/docs/fpm-ford/src/demo10.f90
deleted file mode 100755
index db51f6c1..00000000
--- a/docs/fpm-ford/src/demo10.f90
+++ /dev/null
@@ -1,52 +0,0 @@
-program demo10
-!! @(#) full usage and even equivalencing
-use M_CLI2, only : set_args, get_args, unnamed
-use M_CLI2, only : get_args_fixed_size, get_args_fixed_length
-use M_CLI2, only : specified ! only needed if equivalence keynames
-implicit none
-integer :: i
-
-!! DECLARE "ARGS"
-real :: x, y, z
-real :: point(3), p(3)
-character(len=80) :: title
-logical :: l, l_
-equivalence(point,p)
-
-!! WHEN DEFINING THE PROTOTYPE
- ! o All parameters must be listed with a default value
- ! o string values must be double-quoted
- ! o numeric lists must be comma-delimited. No spaces are allowed
- ! o long keynames must be all lowercase
-
- !! SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES
- call set_args('-x 1 -y 2 -z 3 --point -1,-2,-3 --p -1,-2,-3 --title "my title" -l F -L F')
- !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES
- call get_args('x',x)
- call get_args('y',y)
- call get_args('z',z)
-
- ! note these are equivalenced so one of the calls must be conditional
- call get_args_fixed_size('point',point)
- if(specified('p')) call get_args_fixed_size('p',p)
-
- ! if for some reason you want to use a fixed-length string use
- ! get_args_fixed_length(3f) instead of get_args(3f)
- call get_args_fixed_length('title',title)
-
- call get_args('l',l)
- call get_args('L',l_)
- !! USE THE VALUES IN YOUR PROGRAM.
- write(*,*)'x=',x,'y=',y,'z=',z,'SUM=',x+y+z
- write(*,*)'point=',point,'p=',p
- write(*,*)'title=',trim(title)
- write(*,*)'l=',l,'L=',l_
- !
- ! the optional unnamed values on the command line are
- ! accumulated in the character array "UNNAMED"
- if(size(unnamed) > 0)then
- write(*,'(a)')'files:'
- write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
- endif
-
-end program demo10
diff --git a/docs/fpm-ford/src/demo11.f90 b/docs/fpm-ford/src/demo11.f90
index 1349fe75..6206aa0d 100755
--- a/docs/fpm-ford/src/demo11.f90
+++ b/docs/fpm-ford/src/demo11.f90
@@ -12,35 +12,39 @@ program demo11
character(len=:),allocatable :: name
character(len=:),allocatable :: string
+character(len=:),allocatable :: list(:)
character(len=80) :: readme !(3)
integer :: i
-! M_CLI2 does not have validators except for SPECIFIED(3f) and
-! a check whether the input conforms to the type with get_args(3f)
-! and the convenience functions like inum(3f). But Fortran already
-! has powerful validation capabilities, especially with the use
-! of logical expressions, and ANY(3f) and ALL(3f).
+print *,'demo11: examples of validating values with ALL(3f) and ANY(3f)'
-! A somewhat contrived example of using ALL(3f):
+! M_CLI2 intentionally does not have complex validators except for SPECIFIED(3f) and
+! a check whether the input conforms to the type with get_args(3f)
+! or the convenience functions like inum(3f).
+!
+! Fortran already has powerful validation capabilities. Logical
+! expressions ANY(3f) and ALL(3f) are standard Fortran features easily
+! allow performing the common validations for command line arguments
+! without having to learn any additional syntax or methods.
-! even number from 10 to 30 inclusive
do i=1,100
if(all([i >= 10,i <= 30,(i/2)*2 == i]))then
- write(*,*)'good',i
+ write(*,*)i,' is an even number from 10 to 30 inclusive'
endif
enddo
-! an example of using ANY(3f)
-
-! matched
name='red'
-if(any(name == [character(len=10) :: 'red','white','blue']))then
- write(*,*)'matches ', name
+list = [character(len=10) :: 'red','white','blue']
+if( any(name == list) )then
+ write(*,*)name,' matches a value in the list'
+else
+ write(*,*)name,' not in the list'
endif
-! not matched
-name='teal'
-if(any(name == [character(len=10) :: 'red','white','blue']))then
- write(*,*)'matches ', name
+
+if(size(list).eq.3)then
+ write(*,*)' list has expected number of values'
+else
+ write(*,*)' list does not have expected number of values'
endif
! and even user-defined types can be processed by reading the input
diff --git a/docs/fpm-ford/src/demo12.f90 b/docs/fpm-ford/src/demo12.f90
index bf58a975..0d413ed9 100755
--- a/docs/fpm-ford/src/demo12.f90
+++ b/docs/fpm-ford/src/demo12.f90
@@ -2,7 +2,9 @@ program demo12
!! @(#) using the convenience functions
use M_CLI2, only : set_args, set_mode, rget
implicit none
-real :: x, y, z
+real :: x, y, z
+
+ print *,'demo12: using the convenience functions'
!! ENABLE USING RESPONSE FILES
call set_mode('response file')
diff --git a/docs/fpm-ford/src/demo13.f90 b/docs/fpm-ford/src/demo13.f90
index 1de0aa81..b72edbe1 100755
--- a/docs/fpm-ford/src/demo13.f90
+++ b/docs/fpm-ford/src/demo13.f90
@@ -11,6 +11,9 @@ program demo13
use M_CLI2, only : set_args, lget, set_mode
implicit none
character(len=*),parameter :: all='(*(g0))'
+
+ print *,'demo13: underdash mode'
+
call set_mode('underdash')
call set_args(' --switch_X:X F --switch-Y:Y F ')
print all,'--switch_X or -X ... ',lget('switch_X')
diff --git a/docs/fpm-ford/src/demo14.f90 b/docs/fpm-ford/src/demo14.f90
index 395035df..0af1436b 100755
--- a/docs/fpm-ford/src/demo14.f90
+++ b/docs/fpm-ford/src/demo14.f90
@@ -13,6 +13,9 @@ program demo14
use M_CLI2, only : set_args, lget, set_mode
implicit none
character(len=*),parameter :: all='(*(g0))'
+
+ print *,'demo14: ignorecase mode'
+
call set_mode('ignorecase')
call set_args(' --longName:N F ')
print all,'--longName or -N ... ',lget('longName')
diff --git a/docs/fpm-ford/src/demo15.f90 b/docs/fpm-ford/src/demo15.f90
index 2b9d43e2..a6e20cfe 100755
--- a/docs/fpm-ford/src/demo15.f90
+++ b/docs/fpm-ford/src/demo15.f90
@@ -14,6 +14,9 @@ program demo15
use M_CLI2, only : set_args, lget, set_mode
implicit none
character(len=*),parameter :: all='(*(g0))'
+
+ print *,'demo15: strict mode'
+
call set_mode('strict')
call set_args(' -o F -t F -x F --ox F')
print all,'o=',lget('o'),' t=',lget('t'),' x=',lget('x'),' ox=',lget('ox')
diff --git a/docs/fpm-ford/src/demo17.f90 b/docs/fpm-ford/src/demo17.f90
index f3499f09..c4c2ffc3 100644
--- a/docs/fpm-ford/src/demo17.f90
+++ b/docs/fpm-ford/src/demo17.f90
@@ -1,7 +1,15 @@
program demo17
!! @(#) using the unnamed parameters as filenames
!! For example, this should list the files in the current directory
+!!
!! demo17 *
+!!
+!! Also demonstrates setting --help and --version text.
+!!
+!! demo17 --help
+!! demo17 --version
+!! demo17 --usage
+!!
use M_CLI2, only : get_args
use M_CLI2, only : sget, lget, iget, rget, dget, cget
use M_CLI2, only : sgets, lgets, igets, rgets, dgets, cgets
@@ -36,11 +44,16 @@ program demo17
!! The optional unnamed values on the command line are
!! accumulated in the character array "UNNAMED" which was
!! renamed to "FILENAMES" on the use statement
- if(size(filenames) > 0)then
- print all,'files:'
- print '(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
+ if(allocated(filenames))then
+ if(size(filenames) > 0)then
+ print all,'files:'
+ print '(i6.6,1x,3a)',(indx,'[',filenames(indx),']',indx=1,size(filenames))
+ endif
endif
+ ! alternate method, additionally can be used when desired result is numeric
+ ! by using igets(3f), rgets(3f), ... instead of sgets(3f).
+
fnames=sgets() ! also gets all the unnamed arguments
if(size(fnames) > 0)then
print all,'files:'
@@ -53,6 +66,8 @@ subroutine parse()
!!
use M_CLI2, only : set_args, set_mode
call set_mode([character(len=20) :: 'strict','ignorecase'])
+! a single call to set_args can define the options and their defaults, set help
+! text and version information, and crack command line.
call set_args(&
!! DEFINE COMMAND OPTIONS AND DEFAULT VALUES
' &
diff --git a/docs/fpm-ford/src/demo2.f90 b/docs/fpm-ford/src/demo2.f90
index 16ceba11..d1749836 100755
--- a/docs/fpm-ford/src/demo2.f90
+++ b/docs/fpm-ford/src/demo2.f90
@@ -10,6 +10,8 @@ program demo2
character(len=80) :: title
logical :: l, l_
+ print *,'demo2: all parsing and **help** and **version** information in a contained procedure'
+
call parse() !! DEFINE AND PARSE COMMAND LINE
!! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.
@@ -26,57 +28,57 @@ program demo2
endif
contains
- subroutine parse()
- !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
- use M_CLI2, only : set_args, get_args
- use M_CLI2, only : get_args_fixed_size,get_args_fixed_length
- character(len=:),allocatable :: help_text(:), version_text(:)
+subroutine parse()
+!! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY
+use M_CLI2, only : set_args, get_args
+use M_CLI2, only : get_args_fixed_size,get_args_fixed_length
+character(len=:),allocatable :: help_text(:), version_text(:)
- !! DEFINE COMMAND PROTOTYPE
- !! o All parameters must be listed with a default value
- !! o string values must be double-quoted
- !! o numeric lists must be comma-delimited. No spaces are allowed
- !! o long keynames must be all lowercase
+!! DEFINE COMMAND PROTOTYPE
+!! o All parameters must be listed with a default value
+!! o string values must be double-quoted
+!! o numeric lists must be comma-delimited. No spaces are allowed
+!! o long keynames must be all lowercase
- character(len=*),parameter :: cmd='&
+character(len=*),parameter :: cmd='&
& -x 1 -y 2 -z 3 &
& --point -1,-2,-3 &
& --title "my title" &
& -l F -L F &
& '
- help_text=[character(len=80) :: &
- 'NAME ', &
- ' myprocedure(1) - make all things possible ', &
- 'SYNOPSIS ', &
- ' function myprocedure(stuff) ', &
- ' class(*) :: stuff ', &
- 'DESCRIPTION ', &
- ' myprocedure(1) makes all things possible given STUFF ', &
- 'OPTIONS ', &
- ' STUFF things to do things to ', &
- 'RETURNS ', &
- ' MYPROCEDURE the answers you want ', &
- 'EXAMPLE ', &
- '' ]
+ help_text=[character(len=80) :: &
+ 'NAME ', &
+ ' myprocedure(1) - make all things possible ', &
+ 'SYNOPSIS ', &
+ ' function myprocedure(stuff) ', &
+ ' class(*) :: stuff ', &
+ 'DESCRIPTION ', &
+ ' myprocedure(1) makes all things possible given STUFF ', &
+ 'OPTIONS ', &
+ ' STUFF things to do things to ', &
+ 'RETURNS ', &
+ ' MYPROCEDURE the answers you want ', &
+ 'EXAMPLE ', &
+ '' ]
- version_text=[character(len=80) :: &
- '@(#)PROGRAM: demo2 >', &
- '@(#)DESCRIPTION: My demo program >', &
- '@(#)VERSION: 1.0 20200115 >', &
- '@(#)AUTHOR: me, myself, and I>', &
- '@(#)LICENSE: Public Domain >', &
- '' ]
+ version_text=[character(len=80) :: &
+ '@(#)PROGRAM: demo2 >', &
+ '@(#)DESCRIPTION: My demo program >', &
+ '@(#)VERSION: 1.0 20200115 >', &
+ '@(#)AUTHOR: me, myself, and I>', &
+ '@(#)LICENSE: Public Domain >', &
+ '' ]
- call set_args(cmd, help_text, version_text)
- call get_args('x',x)
- call get_args('y',y)
- call get_args('z',z)
- call get_args_fixed_size('point',point)
- call get_args_fixed_length('title',title)
- call get_args('l',l)
- call get_args('L',l_)
+ call set_args(cmd, help_text, version_text)
+ call get_args('x',x)
+ call get_args('y',y)
+ call get_args('z',z)
+ call get_args_fixed_size('point',point)
+ call get_args_fixed_length('title',title)
+ call get_args('l',l)
+ call get_args('L',l_)
- end subroutine parse
+end subroutine parse
end program demo2
diff --git a/docs/fpm-ford/src/demo3.f90 b/docs/fpm-ford/src/demo3.f90
index ee4dc4bf..45dd4c02 100755
--- a/docs/fpm-ford/src/demo3.f90
+++ b/docs/fpm-ford/src/demo3.f90
@@ -6,9 +6,17 @@ program demo3
logical :: l
real :: size
character(len=:),allocatable :: title
+
+ print *,'demo3: just the bare essentials'
+
+ ! define the command, set default values and read the command line
call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"')
+
+ ! get the values
call get_args('x',x, 'y',y,'l',l, 'size',size) ! all the non-allocatables
- call get_args('title',title)
- ! Done. all variables set and of the right type
+ call get_args('title',title) ! do allocatables one at a time
+
+ ! Done. All variables set and of the requested type
write(*,'(*("[",g0,"]":,1x))')x,y,size,l,title
+
end program demo3
diff --git a/docs/fpm-ford/src/demo4.f90 b/docs/fpm-ford/src/demo4.f90
index 5d122bc4..f3664f69 100755
--- a/docs/fpm-ford/src/demo4.f90
+++ b/docs/fpm-ford/src/demo4.f90
@@ -10,6 +10,8 @@ program demo4
character(len=*),parameter :: form='("(",g0,",",g0,"i)":,1x)'
character(len=*),parameter :: forms='(*("(",g0,",",g0,"i)":,",",1x))'
+ print *,'demo4: COMPLEX argument example'
+
! COMPLEX VALUES
!
! o parenthesis are optional and are ignored in complex values.
diff --git a/docs/fpm-ford/src/demo5.f90 b/docs/fpm-ford/src/demo5.f90
index 7692a0db..f4d5f592 100755
--- a/docs/fpm-ford/src/demo5.f90
+++ b/docs/fpm-ford/src/demo5.f90
@@ -7,8 +7,12 @@ program demo5
implicit none
character(len=*),parameter :: fmt='(*("[",g0,"]":,1x))'
+
+ print *,'demo5: CHARACTER argument examples'
+
call set_args(' &
- & --alloc_len_scalar " " --fx_len_scalar " " &
+ & --alloc_len_scalar " " &
+ & --fx_len_scalar " " &
& --alloc_array "A,B,C" &
& --fx_size_fx_len "A,B,C" &
& --fx_len_alloc_array "A,B,C" &
diff --git a/docs/fpm-ford/src/demo6.f90 b/docs/fpm-ford/src/demo6.f90
index 236405b9..412c653e 100755
--- a/docs/fpm-ford/src/demo6.f90
+++ b/docs/fpm-ford/src/demo6.f90
@@ -19,6 +19,8 @@ program demo6
character(len=80) :: title, testname
logical :: l, l_
+ print *,'demo6: creating subcommands'
+
version_text=[character(len=80) :: &
'@(#)PROGRAM: demo6 >', &
'@(#)DESCRIPTION: My demo program >', &
diff --git a/docs/fpm-ford/src/demo7.f90 b/docs/fpm-ford/src/demo7.f90
index 20ce0fa8..24722b6e 100755
--- a/docs/fpm-ford/src/demo7.f90
+++ b/docs/fpm-ford/src/demo7.f90
@@ -14,6 +14,8 @@ program demo7
complex,allocatable :: complexs(:)
character(len=:),allocatable :: characters(:) ! allocatable array with allocatable length
+ print *,'demo7: controlling array delimiter characters'
+
! ARRAY DELIMITERS
!
! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f)
diff --git a/docs/fpm-ford/src/demo8.f90 b/docs/fpm-ford/src/demo8.f90
index ed236f8d..b9617859 100755
--- a/docs/fpm-ford/src/demo8.f90
+++ b/docs/fpm-ford/src/demo8.f90
@@ -7,13 +7,19 @@ program demo8
real :: size
character(len=80) :: title
character(len=*),parameter :: pairs='(1("[",g0,"=",g0,"]":,1x))'
+
+ print *,'demo8: Sometimes you can put multiple values on getargs(3f)'
+
! DEFINE COMMAND AND PARSE COMMAND LINE
! set all values, double-quote strings
call set_args('-x 1 -y 10 --size 12.34567 -l F --title "my title"' )
+
! GET THE VALUES
! only fixed scalar values (including only character variables that
! are fixed length) may be combined in one GET_ARGS(3f) call
call get_args('x',x, 'y',y, 'l',l, 'size',size, 'title',title)
+
! USE THE VALUES
write(*,fmt=pairs)'X',x,'Y',y,'size',size,'L',l,'TITLE',title
+
end program demo8
diff --git a/docs/fpm-ford/src/demo9.f90 b/docs/fpm-ford/src/demo9.f90
index 79a120eb..9f00893f 100755
--- a/docs/fpm-ford/src/demo9.f90
+++ b/docs/fpm-ford/src/demo9.f90
@@ -1,15 +1,18 @@
program demo9
!> @(#) long and short names using --LONGNAME:SHORTNAME
!!
-!! When all keys have a long and short name "strict mode" is invoked where
-!! "-" is required for short names; and Boolean values may be bundled
-!! together. For example:
+!! When all keys have a long and short name and "strict mode" is invoked
+!! where "-" is required for short names and "--" for long names Boolean
+!! values may be bundled together. For example:
!!
!! demo9 -XYZ
!!
-use M_CLI2, only : set_args, sget, rget, lget
+use M_CLI2, only : set_args, sget, rget, lget, set_mode
implicit none
character(len=*),parameter :: all='(*(g0))'
+
+ print *,'demo9: long and short names using --LONGNAME:SHORTNAME'
+ !call set_mode('strict')
call set_args(' &
& --length:l 10 &
& --height:h 12.45 &
diff --git a/docs/fpm-ford/src/demo_get_args.f90 b/docs/fpm-ford/src/demo_get_args.f90
index 34df95c7..a9bd18df 100755
--- a/docs/fpm-ford/src/demo_get_args.f90
+++ b/docs/fpm-ford/src/demo_get_args.f90
@@ -2,31 +2,29 @@ program demo_get_args
use M_CLI2, only : filenames=>unnamed, set_args, get_args
implicit none
integer :: i
- ! DEFINE ARGS
+ ! Define ARGS
real :: x, y, z
real,allocatable :: p(:)
character(len=:),allocatable :: title
logical :: l, lbig
- ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
- ! o only quote strings and use double-quotes
- ! o set all logical values to F or T.
- call set_args(' &
- & -x 1 -y 2 -z 3 &
- & -p -1,-2,-3 &
+ ! Define and parse (to set initial values) command line
+ ! o only quote strings and use double-quotes
+ ! o set all logical values to F or T.
+ call set_args(' &
+ & -x 1 -y 2 -z 3 &
+ & -p -1,-2,-3 &
& --title "my title" &
- & -l F -L F &
- & --label " " &
+ & -l F -L F &
+ & --label " " &
& ')
- ! ASSIGN VALUES TO ELEMENTS
- ! SCALARS
- call get_args('x',x,'y',y,'z',z)
- call get_args('l',l)
- call get_args('L',lbig)
- ! ALLOCATABLE STRING
+ ! Assign values to elements
+ ! Scalars
+ call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+ ! Allocatable string
call get_args('title',title)
- ! NON-ALLOCATABLE ARRAYS
+ ! Allocatable arrays
call get_args('p',p)
- ! USE VALUES
+ ! Use values
write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
write(*,*)'p=',p
write(*,*)'title=',title
diff --git a/docs/fpm-ford/src/demo_get_args_fixed_length.f90 b/docs/fpm-ford/src/demo_get_args_fixed_length.f90
index 9c01781e..34314d51 100755
--- a/docs/fpm-ford/src/demo_get_args_fixed_length.f90
+++ b/docs/fpm-ford/src/demo_get_args_fixed_length.f90
@@ -1,13 +1,14 @@
program demo_get_args_fixed_length
use M_CLI2, only : set_args, get_args_fixed_length
implicit none
- ! DEFINE ARGS
+
+ ! Define args
character(len=80) :: title
- call set_args(' &
- & --title "my title" &
- & ')
- ! ASSIGN VALUES TO ELEMENTS
- call get_args_fixed_length('title',title)
- ! USE VALUES
- write(*,*)'title=',title
+ ! Parse command line
+ call set_args(' --title "my title" ')
+ ! Assign values to variables
+ call get_args_fixed_length('title',title)
+ ! Use values
+ write(*,*)'title=',title
+
end program demo_get_args_fixed_length
diff --git a/docs/fpm-ford/src/demo_get_subcommand.f90 b/docs/fpm-ford/src/demo_get_subcommand.f90
index cce4e8e2..db95cb7b 100755
--- a/docs/fpm-ford/src/demo_get_subcommand.f90
+++ b/docs/fpm-ford/src/demo_get_subcommand.f90
@@ -5,8 +5,8 @@ program demo_get_subcommand
!x! You can call this program which has two subcommands (run, test),
!x! like this:
!x! demo_get_subcommand --help
- !x! demo_get_subcommand run -x -y -z -title -l -L
- !x! demo_get_subcommand test -title -l -L -testname
+ !x! demo_get_subcommand run -x -y -z --title -l -L
+ !x! demo_get_subcommand test --title -l -L --testname
!x! demo_get_subcommand run --help
implicit none
!x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES
@@ -43,8 +43,8 @@ subroutine parse(name)
! general help for "demo_get_subcommand --help"
help_text=[character(len=80) :: &
' allowed subcommands are ', &
- ' * run -l -L -title -x -y -z ', &
- ' * test -l -L -title ', &
+ ' * run -l -L --title -x -y -z ', &
+ ' * test -l -L --title ', &
'' ]
! find the subcommand name by looking for first word on command
! not starting with dash
diff --git a/docs/fpm-ford/src/demo_set_mode.f90 b/docs/fpm-ford/src/demo_set_mode.f90
index 11a7cc3a..64de24f9 100644
--- a/docs/fpm-ford/src/demo_set_mode.f90
+++ b/docs/fpm-ford/src/demo_set_mode.f90
@@ -6,16 +6,16 @@ program demo_set_mode
! enable use of response files
call set_mode('response_file')
!
- ! Any dash in a keyname is treated as an underscore
+ ! Any dash in a keyword is treated as an underscore
call set_mode('underdash')
!
- ! The case of long keynames are ignored.
+ ! The case of long keywords are ignored.
! Values and short names remain case-sensitive
call set_mode('ignorecase')
!
! short single-character boolean keys may be bundled
! but it is required that a single dash is used for
- ! short keys and a double dash for long keynames.
+ ! short keys and a double dash for long keywords.
call set_mode('strict')
!
call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F')
diff --git a/docs/fpm-ford/src/demo_specified.f90 b/docs/fpm-ford/src/demo_specified.f90
index 1a40eef2..3d7b2ff6 100755
--- a/docs/fpm-ford/src/demo_specified.f90
+++ b/docs/fpm-ford/src/demo_specified.f90
@@ -1,43 +1,77 @@
program demo_specified
- use M_CLI2, only : set_args, get_args, specified
+ use, intrinsic :: iso_fortran_env, only : &
+ & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT
+ use M_CLI2, only : set_args, igets, rgets, specified, sget, lget
implicit none
- ! DEFINE ARGS
- integer :: flag
- integer,allocatable :: ints(:)
- real,allocatable :: two_names(:)
- ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED
- ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM
+ ! Define args
+ integer,allocatable :: ints(:)
+ real,allocatable :: floats(:)
+ logical :: flag
+ character(len=:),allocatable :: color
+ character(len=:),allocatable :: list(:)
+ integer :: i
+
call set_args('&
- & --flag 1 -f 1 &
- & --ints 1,2,3 -i 1,2,3 &
- & --two_names 11.3 -T 11.3')
-
- ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME
- call get_args('flag',flag)
- if(specified('f'))call get_args('f',flag)
- call get_args('ints',ints)
- if(specified('i'))call get_args('i',ints)
- call get_args('two_names',two_names)
- if(specified('T'))call get_args('T',two_names)
-
- ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE
+ & --color:c "red" &
+ & --flag:f F &
+ & --ints:i 1,10,11 &
+ & --floats:T 12.3, 4.56 &
+ & ')
+ ints=igets('ints')
+ floats=rgets('floats')
+ flag=lget('flag')
+ color=sget('color')
+
+ write(*,*)'color=',color
+ write(*,*)'flag=',flag
+ write(*,*)'ints=',ints
+ write(*,*)'floats=',floats
+
+ write(*,*)'was -flag specified?',specified('flag')
+
+ ! elemental
+ write(*,*)specified(['floats','ints '])
+
+ ! If you want to know if groups of parameters were specified use
! ANY(3f) and ALL(3f)
- write(*,*)specified(['two_names','T '])
- write(*,*)'ANY:',any(specified(['two_names','T ']))
- write(*,*)'ALL:',all(specified(['two_names','T ']))
+ write(*,*)'ANY:',any(specified(['floats','ints ']))
+ write(*,*)'ALL:',all(specified(['floats','ints ']))
- ! FOR MUTUALLY EXCLUSIVE
- if (all(specified(['two_names','T '])))then
- write(*,*)'You specified both names -T and -two_names'
+ ! For mutually exclusive
+ if (all(specified(['floats','ints '])))then
+ write(*,*)'You specified both names --ints and --floats'
endif
- ! FOR REQUIRED PARAMETER
- if (.not.any(specified(['two_names','T '])))then
- write(*,*)'You must specify -T or -two_names'
+ ! For required parameter
+ if (.not.any(specified(['floats','ints '])))then
+ write(*,*)'You must specify --ints or --floats'
endif
- ! USE VALUES
- write(*,*)'flag=',flag
- write(*,*)'ints=',ints
- write(*,*)'two_names=',two_names
- end program demo_specified
+
+ ! check if all values are in range from 10 to 30 and even
+ write(*,*)'are all numbers good?',all([ints >= 10,ints <= 30,(ints/2)*2 == ints])
+
+ ! perhaps you want to check one value at a time
+ do i=1,size(ints)
+ write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]
+ if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then
+ write(*,*)ints(i),'is an even number from 10 to 30 inclusive'
+ else
+ write(*,*)ints(i),'is not an even number from 10 to 30 inclusive'
+ endif
+ enddo
+
+ list = [character(len=10) :: 'red','white','blue']
+ if( any(color == list) )then
+ write(*,*)color,'matches a value in the list'
+ else
+ write(*,*)color,'not in the list'
+ endif
+
+ if(size(ints).eq.3)then
+ write(*,*)'ints(:) has expected number of values'
+ else
+ write(*,*)'ints(:) does not have expected number of values'
+ endif
+
+ end program demo_specified
diff --git a/docs/fpm-ford/src/test_ignorecase.f90 b/docs/fpm-ford/src/test_ignorecase.f90
index 2b6a12f4..d2951b04 100755
--- a/docs/fpm-ford/src/test_ignorecase.f90
+++ b/docs/fpm-ford/src/test_ignorecase.f90
@@ -5,20 +5,19 @@ program test_ignorecase
use M_CLI2, only : set_args, sget, igets, rgets, dgets, lget, set_mode
implicit none
character(len=*),parameter :: it='(1x,*(g0,1x))'
-logical,parameter :: T=.true., F=.false.
character(len=:),allocatable :: whichone
character(len=:),allocatable :: arr(:)
call set_mode('ignorecase')
call set_args(' --type run -a "a AA a" -b "B bb B" -A AAA -B BBB --longa:O " OoO " --longb:X "xXx"')
whichone=sget('type')
- arr=[character(len=10) :: sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X') ]
+ arr=[character(len=17) :: sget('a'),sget('b'),sget('A'),sget('B'),sget('longa'),sget('longb'),sget('O'),sget('X') ]
select case(whichone)
- case('one') ; call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
- case('two') ; call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
- case('three') ; call testit(whichone,all([character(len=10)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
- case('four') ; call testit(whichone,all([character(len=10)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
- case('five') ; call testit(whichone,all([character(len=10)::'a AA a','B bb B','AAA','BBB', &
+ case('one') ; call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB',' OoO','xXx',' OoO','xXx']==arr))
+ case('two') ; call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+ case('three') ; call testit(whichone,all([character(len=17)::'a','b','A','B','longa O','longb X','longa O','longb X']==arr))
+ case('four') ; call testit(whichone,all([character(len=17)::'a A','b B','SET A','SET B',' OoO','xXx',' OoO','xXx']==arr))
+ case('five') ; call testit(whichone,all([character(len=17)::'a AA a','B bb B','AAA','BBB', &
& 'a b c d e f g h i','xXx','a b c d e f g h i','xXx']==arr))
case('six') ; !call testit(whichone, all(arr))
case('run')
diff --git a/docs/fpm-ford/src/test_syntax.f90 b/docs/fpm-ford/src/test_syntax.f90
index 8119eb17..4e9ddab6 100755
--- a/docs/fpm-ford/src/test_syntax.f90
+++ b/docs/fpm-ford/src/test_syntax.f90
@@ -5,7 +5,6 @@ program test_syntax
use M_CLI2, only : set_args, sget, sgets, iget, igets, rget, rgets, dget, dgets, lget, lgets
implicit none
character(len=*),parameter :: it='(1x,*(g0,1x))'
-logical,parameter :: T=.true., F=.false.
character(len=:),allocatable :: whichone
call set_args(' --type run -i 1 --ints:I 1,2,3 -s " " --strings " " -r 0.0 --reals:R 11.1,22.2,33.3')
diff --git a/docs/fpm-ford/tipuesearch/tipuesearch_content.js b/docs/fpm-ford/tipuesearch/tipuesearch_content.js
index dcb825ae..8d038920 100644
--- a/docs/fpm-ford/tipuesearch/tipuesearch_content.js
+++ b/docs/fpm-ford/tipuesearch/tipuesearch_content.js
@@ -1 +1 @@
-var tipuesearch = {"pages":[{"title":" M_CLI2 ","text":"M_CLI2 M_CLI2.f90 and associated files Name M_CLI2 - parse Unix-like command line arguments from Fortran Description M_CLI2(3f) is a Fortran module that will crack the command line when\n given a prototype string that looks very much like an invocation of\n the program. A call to get_args(3f) or one of its variants is then\n made for each parameter name to set the variables appropriately in\n the program. Example Program This short program defines a command that can be called like ./show -x 10 -y -20 -p 10 ,20,30 --title 'plot of stuff' -L # these parameters are defined automatically ./show --usage \n ./show --help\n ./show --version # you must supply text for \"help\" and \"version\" if desired. program show use M_CLI2 , only : set_args , lget , rget , sget , igets implicit none real :: sum integer , allocatable :: p (:) character ( len = :), allocatable :: title logical :: l , lbig ! ! Define command and default values and parse supplied command line options ! call set_args ( '-x 1 -y 2.0 -z 3.5e0 -p 11,-22,33 --title \"my title\" -l F -L F' ) ! ! Get values using convenience functions ! sum = rget ( 'x' ) + rget ( 'y' ) + rget ( 'z' ) title = sget ( 'title' ) p = igets ( 'p' ) l = lget ( 'l' ) lbig = lget ( 'L' ) ! ! All ready to go ! write ( * , * ) sum , l , lbig , p , title end program show An arbitrary number of strings such as filenames may be passed in on\nthe end of commands, you can query whether an option was supplied, and\nget_args(3f)-related routines can be used for refining options such as\nrequiring lists of a specified size. Passing in some character arrays\nallows you to automatically have a –help and –version switch as well,\nas explained using the examples below. Demo Programs These demo programs provide templates for the most common usage: demo1 Using the convenience functions demo2 Putting everything including help and version information into a contained procedure. demo3 Example of basic use demo4 COMPLEX type values demo5 CHARACTER type values demo6 How to create a command with subcommands demo7 Controlling array delimiter characters demo8 Parsing multiple keywords in a single call to get_args(3f) for limited cases demo9 Long and short names using –LONGNAME:SHORTNAME. When all keys have \n a long and short name “strict mode” is invoked where “–” is required\n for long names and “-” for short names; and Boolean values may be \n bundled together. demo10 Full usage and even equivalencing Optional Modes demo12 Enabling response files demo13 Equivalencing dash to underscore in keynames demo14 Case-insensitive long keys demo15 bundling short Boolean keys using “strict” mode Download and Build with Make(1) Compile the M_CLI2 module and build all the example programs. git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2/src # change Makefile if not using one of the listed compilers # for gfortran make clean\n make gfortran # for ifort make clean\n make ifort # for nvfortran make clean\n make nvfortran # display other options (test, run, doxygen, ford, ...) make help To install you then generally copy the .mod file and .a file to\n an appropriate directory. Unfortunately, the specifics vary but in\n general if you have a directory $HOME/.local/lib and copy those files\n there then you can generally enter something like gfortran -L $HOME /.local/lib -lM_CLI2 myprogram.f90 -o myprogram There are different methods for adding the directory to your default\n load path, but frequently you can append the directory you have\n placed the files in into the colon-separated list of directories\n in the $LD_LIBRARY_PATH or $LIBRARY_PATH environment variable, and\n then the -L option will not be required (or it’s equivalent in your\n programming environment). export LD_LIBRARY_PATH = $HOME /.local/lib: $LD_LIBRARY_PATH NOTE : If you use multiple Fortran compilers you may need to create\n a different directory for each compiler. I would recommend it, such\n as $HOME/.local/lib/gfortran/. If you desire a shared library as well, for gfortran you may enter make clean gfortran gfortran_install and everything needed by gfortran will be placed in libgfortran/ that\n you may add to an appropriate area, such as $HOME/.local/lib/gfortran/. make clean ifort ifort_install # same for ifort NOTE: These instructions are specific to a ULS (Unix-Like System) and \n may differ, especially for those wishing to generate shared libraries\n which varies significantly from compiler to compiler. For some builds\n it is simpler to make a Makefile for each compiler, which might be\n required for a more comprehensive build unless you are very familiar\n with gmake(1). If you always use one compiler it is relatively simple, otherwise\n make sure you know what your system requires and change the Makefile\n as appropriate. Supports FPM Alternatively, fpm(1) users may download the github repository and build it with\n fpm ( as described at Fortran Package Manager ) git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2\n fpm test # build and test the module fpm install # install the module (in the default location) or just list it as a dependency in your fpm.toml project file. [dependencies] M_CLI2 = { git = \"https://github.com/urbanjost/M_CLI2.git\" } Supports Meson Alternatively, meson(1) users may download the github repository and build it with\n meson ( as described at Meson Build System ) git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2\n meson setup _build\n meson test -C _build # build and test the module meson install -C _build --destdir # install the module (in the location) or just list it as a subproject dependency in your meson.build project file. M_CLI2_dep = subproject ( 'M_CLI2' ). get_variable ( 'M_CLI2_dep' ) Functional Specification This is how the interface works – Pass in a string to set_args(3f) that looks almost like the command\n you would use to execute the program except with all keywords and\n default values specified. you add calls to the get_args(3f) procedure or one of its variants (\n The alternatives allow you to use a simple function-based interface\n model. There are special routines for when you want to use fixed length.\n CHARACTER variables or fixed-size arrays instead of the allocatable\n variables best used with get_args(3f)). Now when you call the program all the values in the prototype should\n be updated using values from the command line and queried and ready\n to use in your program. Response files Response files are supported as described in the documentation for set_args .\nThey are a system-independent way to create short abbreviations for long\ncomplex commands. This option is generally not needed by programs with\njust a few options, but can be particularly useful for programs with\ndozens of options where various values are frequently reused. Documentation man-pages as HTML man-pages – man-pages index of individual procedures BOOK_M_CLI2 – All man-pages consolidated using JavaScript real man-pages manpages.zip manpages.tgz developer documentation doxygen(1) output . ford(1) output . logs CHANGELOG STATUS of most recent CI/CD runs Commit Tests commit 598e44164eee383b8a0775aa75b7d1bb100481c3 was tested on 2020-11-22 with\n + GNU Fortran (GCC) 8.3.1 20191121 (Red Hat 8.3.1-5)\n + ifort (IFORT) 19.1.3.304 20200925\n + nvfortran 20.7-0 LLVM 64-bit target on x86-64 Linux commit 8fe841d8c0c1867f88847e24009a76a98484b31a was tested on 2021-09-29 with\n + GNU Fortran (Ubuntu 10.3.0-1ubuntu1~20.04) 10.3.0\n + ifort (IFORT) 2021.3.0 20210609\n + nvfortran 21.5-0 LLVM 64-bit target on x86-64 Linux -tp nehalem Last update: Sat 21 Jan 2023 11:10:53 PM EST Developer Info John S. Urban","tags":"home","loc":"index.html"},{"title":"point – M_CLI2 ","text":"type :: point Contents Variables color x y Source Code point Components Type Visibility Attributes Name Initial character(len=20), public :: color = 'red' integer, public :: x = 0 integer, public :: y = 0 Source Code type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point","tags":"","loc":"type/point.html"},{"title":"cget – M_CLI2","text":"public function cget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex Contents Source Code cget Source Code function cget ( n ); complex :: cget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , cget ); end function cget","tags":"","loc":"proc/cget.html"},{"title":"dget – M_CLI2","text":"public function dget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp) Contents Source Code dget Source Code function dget ( n ); real ( kind = dp ) :: dget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , dget ); end function dget","tags":"","loc":"proc/dget.html"},{"title":"get_subcommand – M_CLI2","text":"public function get_subcommand() result(sub) NAME get_subcommand ( 3 f ) - [ ARGUMENTS : M_CLI2 ] special - case routine for handling subcommands on a command line ( LICENSE : PD ) SYNOPSIS function get_subcommand () character ( len =:), allocatable :: get_subcommand DESCRIPTION In the special case when creating a program with subcommands it\nis assumed the first word on the command line is the subcommand. A\nroutine is required to handle response file processing, therefore\nthis routine (optionally processing response files) returns that\nfirst word as the subcommand name.\n\nIt should not be used by programs not building a more elaborate\ncommand with subcommands. RETURNS NAME name of subcommand EXAMPLE Sample program: program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z -title -l -L !x! demo_get_subcommand test -title -l -L -testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x = - 999.0 , y = - 999.0 , z = - 999.0 character ( len = 80 ) :: title = \"not set\" logical :: l =. false . logical :: l_ =. false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) ! x ! DEFINE AND PARSE COMMAND LINE ! x ! ALL DONE CRACKING THE COMMAND LINE . ! x ! USE THE VALUES IN YOUR PROGRAM . write ( * , * ) ' command was ',name write(*,*)' x , y , z ... . ',x,y,z write ( * , * ) ' title ... . ',title write ( * , * ) ' l , l_ ... .. ',l,l_ write ( * , * ) ' testname . ',testname contains subroutine parse(name) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2, only : set_args, get_args, get_args_fixed_length use M_CLI2, only : get_subcommand, set_mode character(len=*) :: name ! the subcommand name character(len=:),allocatable :: help_text(:), version_text(:) call set_mode(' response_file ' ) ! define version text version_text =[ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text =[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text =[ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , & & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text =[ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( & & '--title \"my title\" -l F -L F --testname \"Test\"' , & & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) ' unknown or missing subcommand [ ',trim(name),' ] ' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments None Return Value character(len=:), allocatable Contents Source Code get_subcommand Source Code function get_subcommand () result ( sub ) ! ident_3=\"@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files\" character ( len = :), allocatable :: sub character ( len = :), allocatable :: cmdarg character ( len = :), allocatable :: array (:) character ( len = :), allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand = '' G_options_only = . true . sub = '' if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif ilongest = longest_command_argument () allocate ( character ( len = max ( 63 , ilongest )) :: cmdarg ) cmdarg (:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( scan ( adjustl ( cmdarg ( 1 : 1 )), '@' ) == 1 ) then call get_prototype ( cmdarg , prototype ) call split ( prototype , array ) ! assume that if using subcommands first word not starting with dash is the subcommand do j = 1 , size ( array ) if ( adjustl ( array ( j )( 1 : 1 )) /= '-' ) then G_subcommand = trim ( array ( j )) sub = G_subcommand exit endif enddo endif enddo if ( G_subcommand /= '' ) then sub = G_subcommand elseif ( size ( unnamed ) /= 0 ) then sub = unnamed ( 1 ) else cmdarg (:) = '' do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( adjustl ( cmdarg ( 1 : 1 )) /= '-' ) then sub = trim ( cmdarg ) exit endif enddo endif G_options_only = . false . end function get_subcommand","tags":"","loc":"proc/get_subcommand.html"},{"title":"iget – M_CLI2","text":"public function iget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer Contents Source Code iget Source Code function iget ( n ); integer :: iget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , iget ); end function iget","tags":"","loc":"proc/iget.html"},{"title":"lget – M_CLI2","text":"public function lget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical Contents Source Code lget Source Code function lget ( n ); logical :: lget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , lget ); end function lget","tags":"","loc":"proc/lget.html"},{"title":"rget – M_CLI2","text":"public function rget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real Contents Source Code rget Source Code function rget ( n ); real :: rget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , rget ); end function rget","tags":"","loc":"proc/rget.html"},{"title":"sget – M_CLI2","text":"public function sget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value character(len=:), allocatable Contents Source Code sget Source Code function sget ( n ); character ( len = :), allocatable :: sget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , sget ); end function sget","tags":"","loc":"proc/sget.html"},{"title":"specified – M_CLI2","text":"public impure elemental function specified(key) NAME specified ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return true if keyword was present on command line ( LICENSE : PD ) SYNOPSIS elemental impure function specified(name)\n\n character(len=*),intent(in) :: name\n logical :: specified DESCRIPTION specified ( 3 f ) returns . true . if the specified keyword was present on the command line . OPTIONS NAME name of commandline argument to query the presence of RETURNS SPECIFIED returns . TRUE . if specified NAME was present on the command line when the program was invoked . EXAMPLE Sample program: program demo_specified use M_CLI2 , only : set_args , get_args , specified implicit none ! DEFINE ARGS integer :: flag integer , allocatable :: ints ( : ) real , allocatable :: two_names ( : ) ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM call set_args ( ' & & -- flag 1 - f 1 & & -- ints 1 , 2 , 3 - i 1 , 2 , 3 & & -- two_names 11 . 3 - T 11 . 3 ' ) ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME call get_args ( ' flag ' , flag ) if ( specified ( ' f ' )) call get_args ( ' f ' , flag ) call get_args ( ' ints ' , ints ) if ( specified ( ' i ' )) call get_args ( ' i ' , ints ) call get_args ( ' two_names ' , two_names ) if ( specified ( ' T ' )) call get_args ( ' T ' , two_names ) ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE ! ANY ( 3 f ) and ALL ( 3 f ) write ( * , * ) specified ( [ ' two_names ' , ' T ' ] ) write ( * , * ) ' ANY: ' , any ( specified ( [ ' two_names ' , ' T ' ] )) write ( * , * ) ' ALL: ' , all ( specified ( [ ' two_names ' , ' T ' ] )) ! FOR MUTUALLY EXCLUSIVE if ( all ( specified ( [ ' two_names ' , ' T ' ] ))) then write ( * , * ) ' You specified both names -T and -two_names ' endif ! FOR REQUIRED PARAMETER if ( . not . any ( specified ( [ ' two_names ' , ' T ' ] ))) then write ( * , * ) ' You must specify -T or -two_names ' endif ! USE VALUES write ( * , * ) ' flag= ' , flag write ( * , * ) ' ints= ' , ints write ( * , * ) ' two_names= ' , two_names end program demo_specified AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key Return Value logical Contents Source Code specified Source Code elemental impure function specified ( key ) character ( len =* ), intent ( in ) :: key logical :: specified integer :: place call locate_key ( key , place ) ! find where string is or should be if ( place < 1 ) then specified = . false . else specified = present_in ( place ) endif end function specified","tags":"","loc":"proc/specified.html"},{"title":"print_dictionary – M_CLI2","text":"public subroutine print_dictionary(header, stop) NAME print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary\ncreated by calls to set_args(3f)\n(LICENSE:PD) SYNOPSIS subroutine print_dictionary(header,stop)\n\n character(len=*),intent(in),optional :: header\n logical,intent(in),optional :: stop DESCRIPTION Print the internal dictionary created by calls to set_args ( 3 f ) . This routine is intended to print the state of the argument list if an error occurs in using the set_args ( 3 f ) procedure . OPTIONS HEADER label to print before printing the state of the command argument list . STOP logical value that if true stops the program after displaying the dictionary . EXAMPLE Typical usage: program demo_print_dictionary use M_CLI2 , only : set_args , get_args implicit none real :: x , y , z call set_args ( '-x 10 -y 20 -z 30' ) call get_args ( 'x' , x , 'y' , y , 'z' , z ) ! all done cracking the command line ; use the values in your program . write ( * , * ) x , y , z end program demo_print_dictionary Sample output Calling the sample program with an unknown parameter or the -- usage switch produces the following : $ . / demo_print_dictionary - A UNKNOWN SHORT KEYWORD : - A KEYWORD PRESENT VALUE z F [ 3 ] y F [ 2 ] x F [ 1 ] help F [ F ] version F [ F ] usage F [ F ] AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in), optional :: header logical, intent(in), optional :: stop Contents Source Code print_dictionary Source Code subroutine print_dictionary ( header , stop ) character ( len =* ), intent ( in ), optional :: header logical , intent ( in ), optional :: stop integer :: i if ( G_QUIET ) return if ( present ( header )) then if ( header /= '' ) then write ( warn , '(a)' ) header endif endif if ( allocated ( keywords )) then if ( size ( keywords ) > 0 ) then write ( warn , '(a,1x,a,1x,a,1x,a)' ) atleast ( 'KEYWORD' , max ( len ( keywords ), 8 )), 'SHORT' , 'PRESENT' , 'VALUE' write ( warn , '(*(a,1x,a5,1x,l1,8x,\"[\",a,\"]\",/))' ) & & ( atleast ( keywords ( i ), max ( len ( keywords ), 8 )), shorts ( i ), present_in ( i ), values ( i )(: counts ( i )), i = 1 , size ( keywords )) endif endif if ( allocated ( unnamed )) then if ( size ( unnamed ) > 0 ) then write ( warn , '(a)' ) 'UNNAMED' write ( warn , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif endif if ( allocated ( args )) then if ( size ( args ) > 0 ) then write ( warn , '(a)' ) 'ARGS' write ( warn , '(i6.6,3a)' )( i , '[' , args ( i ), ']' , i = 1 , size ( args )) endif endif if ( G_remaining /= '' ) then write ( warn , '(a)' ) 'REMAINING' write ( warn , '(a)' ) G_remaining endif if ( present ( stop )) then if ( stop ) call mystop ( 5 ) endif end subroutine print_dictionary","tags":"","loc":"proc/print_dictionary.html"},{"title":"set_args – M_CLI2","text":"public subroutine set_args(prototype, help_text, version_text, string, prefix, ierr, errmsg) NAME set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing\n(LICENSE:PD) SYNOPSIS subroutine set_args(definition,help_text,version_text,ierr,errmsg)\n\n character(len=*),intent(in),optional :: definition\n character(len=*),intent(in),optional :: help_text(:)\n character(len=*),intent(in),optional :: version_text(:)\n integer,intent(out),optional :: ierr\n character(len=:),intent(out),allocatable,optional :: errmsg DESCRIPTION SET_ARGS ( 3 f ) requires a 1 - like command prototype for defining arguments and default command - line options . Argument values are then read using GET_ARGS ( 3 f ) . The -- help and -- version options require the optional help_text and version_text values to be provided . OPTIONS DEFINITION composed of all command arguments concatenated into a Unix - like command prototype string . For example : call set_args ( ' -L F --ints 1,2,3 --title \"my title\" -R 10.3 ' ) DEFINITION is pre - defined to act as if started with the reserved options ' --verbose F --usage F --help F -- version F ' . The --usage option is processed when the set_args ( 3 f ) routine is called . The same is true for -- help and -- version if the optional help_text and version_text options are provided . see \" DEFINING THE PROTOTYPE \" in the next section for further details . HELP_TEXT if present , will be displayed if program is called with -- help switch , and then the program will terminate . If not supplied , the command line initialization string will be shown when -- help is used on the commandline . VERSION_TEXT if present , will be displayed if program is called with -- version switch , and then the program will terminate . IERR if present a non - zero option is returned when an error occurs instead of program execution being terminated ERRMSG a description of the error if ierr is present DEFINING THE PROTOTYPE o all keywords on the prototype MUST get a value . + logicals must be set to F or T . + strings must be delimited with double - quotes and must be at least one space . Internal double - quotes are represented with two double - quotes . o numeric keywords are not allowed ; but this allows negative numbers to be used as values . o lists of values should be comma - delimited unless a user - specified delimiter is used . The prototype must use the same array delimiters as the call to get the value . o to define a zero - length allocatable array make the value a delimiter ( usually a comma ) . o all unused values go into the character array UNNAMED LONG AND SHORT NAMES o It is recommended long names ( -- keyword ) should be all lowercase but are case - sensitive by default , unless set_mode ( 'ignorecase' ) is in effect . o Long names should always be more than one character . o The recommended way to have short names is to suffix the long name with : LETTER in the definition . If this syntax is used then logical shorts may be combined on the command line . Mapping of short names to long names __not__ using the -- LONGNAME : SHORTNAME syntax is demonstrated in the manpage for SPECIFIED ( 3 f ) . SPECIAL BEHAVIORS o A very special behavior occurs if the keyword name ends in :: . When the program is called the next parameter is taken as a value even if it starts with -. This is not generally recommended but is useful in rare cases where non - numeric values starting with a dash are desired . o If the prototype ends with \"--\" a special mode is turned on where anything after \"--\" on input goes into the variable REMAINING and the array ARGS instead of becoming elements in the UNNAMED array . This is not needed for normal processing . USAGE When invoking the program line note that ( subject to change ) the following variations from other common command - line parsers : o values for duplicate keywords are appended together with a space separator when a command line is executed . o Although not generally recommended you can equivalence keywords ( usually for multi - lingual support ) . Be aware that specifying both names of an equivalenced keyword on a command line will have undefined results ( currently , their ASCII alphabetical order will define what the Fortran variable values become ) . The second of the names should only be queried if the SPECIFIED ( 3 f ) function is . TRUE . for that name . Note that allocatable arrays cannot be EQUIVALENCEd in Fortran . o short Boolean keywords cannot be combined reliably unless \"set_mode('strict')\" is in effect . Short names that require a value cannot be bundled together . Non - Boolean key names may not be bundled . o shuffling is not supported . Values immediately follow their keywords . o if a parameter value of just \"-\" is supplied it is converted to the string \"stdin\" . o values not matching a keyword go into the character array \"UNUSED\" . o if the keyword \"--\" is encountered on the command line the rest of the command arguments go into the character array \"UNUSED\" . EXAMPLE Sample program: program demo_set_args use M_CLI2 , only : filenames => unnamed , set_args , get_args use M_CLI2 , only : get_args_fixed_size implicit none integer :: i ! DEFINE ARGS real :: x , y , z real :: p ( 3 ) character ( len = : ) , allocatable :: title logical :: l , lbig integer , allocatable :: ints ( : ) ! ! DEFINE COMMAND ( TO SET INITIAL VALUES AND ALLOWED KEYWORDS ) ! AND READ COMMAND LINE call set_args ( ' & ! reals & - x 1 - y 2 . 3 - z 3 . 4 e2 & ! integer array & - p - 1 , - 2 , - 3 & ! always double - quote strings & -- title \" my title \" & ! string should be a single character at a minimum & -- label \" \" , & ! set all logical values to F or T . & - l F - L F & ! set allocatable size to zero if you like by using a delimiter & -- ints , & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( ' x ' , x ) call get_args ( ' y ' , y ) call get_args ( ' z ' , z ) call get_args ( ' l ' , l ) call get_args ( ' L ' , lbig ) call get_args ( ' ints ' , ints ) ! ALLOCATABLE ARRAY call get_args ( ' title ' , title ) ! ALLOCATABLE STRING call get_args_fixed_size ( ' p ' , p ) ! NON - ALLOCATABLE ARRAY ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' y= ' , y write ( * , * ) ' z= ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' ints= ' , ints write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig ! UNNAMED VALUES if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_set_args RESPONSE FILES If you have no interest in using external files as abbreviations\n you can ignore this section. Otherwise, before calling set_args(3f)\n add: use M_CLI2, only : set_mode\n call set_mode('response_file') M_CLI2 Response files are small files containing CLI (Command Line\n Interface) arguments that end with “.rsp” that can be used when command\n lines are so long that they would exceed line length limits or so complex\n that it is useful to have a platform-independent method of creating\n an abbreviation. Shell aliases and scripts are often used for similar purposes (and\n allow for much more complex conditional execution, of course), but\n they generally cannot be used to overcome line length limits and are\n typically platform-specific. Examples of commands that support similar response files are the Clang\n and Intel compilers, although there is no standard format for the files. They are read if you add options of the syntax “@NAME” as the FIRST\n parameters on your program command line calls. They are not recursive –\n that is, an option in a response file cannot be given the value “@NAME2”\n to call another response file. More than one response name may appear on a command line. They are case-sensitive names. Note “@” s a special character in Powershell, and requires being escaped\n with a grave character. LOCATING RESPONSE FILES A search for the response file always starts with the current directory.\n The search then proceeds to look in any additional directories specified\n with the colon-delimited environment variable CLI_RESPONSE_PATH. The first resource file found that results in lines being processed\n will be used and processing stops after that first match is found. If\n no match is found an error occurs and the program is stopped. RESPONSE FILE SECTIONS A simple response file just has options for calling the program in it\n prefixed with the word “options”.\n But they can also contain section headers to denote selections that are\n only executed when a specific OS is being used, print messages, and\n execute system commands. SEARCHING FOR OSTYPE IN REGULAR FILES So assuming the name @NAME was specified on the command line a file\n named NAME.rsp will be searched for in all the search directories\n and then in that file a string that starts with the string @OSTYPE\n (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE\n takes precedence over $OS). SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES Then, the same files will be searched for lines above any line starting\n with “@”. That is, if there is no special section for the current OS\n it just looks at the top of the file for unlabeled options. SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE In addition or instead of files with the same name as the @NAME option\n on the command line, you can have one file named after the executable\n name that contains multiple abbreviation names. So if your program executable is named EXEC you create a single file\n called EXEC.rsp and can append all the simple files described above\n separating them with lines of the form @OSTYPE@NAME or just @NAME. So if no specific file for the abbreviation is found a file called\n “EXEC.rsp” is searched for where “EXEC” is the name of the executable.\n This file is always a “compound” response file that uses the following format: Any compound EXEC.rsp file found in the current or searched directories\n will be searched for the string @OSTYPE@NAME first. Then if nothing is found, the less specific line @NAME is searched for. THE SEARCH IS OVER Sounds complicated but actually works quite intuitively. Make a file in\n the current directory and put options in it and it will be used. If that\n file ends up needing different cases for different platforms add a line\n like “@Linux” to the file and some more lines and that will only be\n executed if the environment variable OSTYPE or OS is “Linux”. If no match\n is found for named sections the lines at the top before any “@” lines\n will be used as a default if no match is found. If you end up using a lot of files like this you can combine them all\n together and put them into a file called “program_name”.rsp and just\n put lines like @NAME or @OSTYPE@NAME at that top of each selection. Now, back to the details on just what you can put in the files. SPECIFICATION FOR RESPONSE FILES SIMPLE RESPONSE FILES The first word of a line is special and has the following meanings: options |- Command options following the rules of the SET_ARGS ( 3 f ) prototype . So o It is preferred to specify a value for all options . o double - quote strings . o give a blank string value as \" \" . o use F | T for lists of logicals , o lists of numbers should be comma - delimited . o -- usage , -- help , -- version , -- verbose , and unknown options are ignored . comment | # Line is a comment line system |! System command . System commands are executed as a simple call to system ( so a cd ( 1 ) or setting a shell variable would not effect subsequent lines , for example ) BEFORE the command being processed . print |> Message to screen stop display message and stop program . NOTE: system commands are executed when encountered, but options are\n gathered from multiple option lines and passed together at the end of\n processing of the block; so all commands will be executed BEFORE the\n command for which options are being supplied no matter where they occur. So if a program that does nothing but echos its parameters program testit use M_CLI2 , only : set_args , rget , sget , lget , set_mode implicit none real :: x , y ; namelist/args/ x,y character ( len = : ) , allocatable :: title ; namelist/args/ title logical :: big ; namelist/args/ big call set_mode ( ' response_file ' ) call set_args ( ' -x 10.0 -y 20.0 --title \"my title\" --big F ' ) x = rget ( ' x ' ) y = rget ( ' y ' ) title = sget ( ' title ' ) big = lget ( ' big ' ) write ( * , nml = args ) end program testit And a file in the current directory called “a.rsp” contains # defaults for project A options - x 1000 - y 9999 options -- title \" \" options -- big T The program could be called with $ myprog # normal call X = 10.0 Y = 20.0 TITLE = \"my title\" $ myprog @a # change defaults as specified in \"a.rsp\" X = 1000.0 Y = 9999.0 TITLE = \" \" # change defaults but use any option as normal to override defaults $ myprog @a - y 1234 X = 1000.0 Y = 1234.0 TITLE = \" \" COMPOUND RESPONSE FILES A compound response file has the same basename as the executable with a\n “.rsp” suffix added. So if your program is named “myprg” the filename\n must be “myprg.rsp”. Note that here `basename` means the last leaf of the name of the program as returned by the Fortran intrinsic GET_COMMAND_ARGUMENT ( 0 ,...) trimmed of anything after a period ( \".\" ), so it is a good idea not to use hidden files . Unlike simple response files compound response files can contain multiple\n setting names. Specifically in a compound file\n if the environment variable $OSTYPE (first) or $OS is set the first search\n will be for a line of the form (no leading spaces should be used): @OSTYPE@alias_name If no match or if the environment variables $OSTYPE and $OS were not\n set or a match is not found then a line of the form @alias_name is searched for in simple or compound files. If found subsequent lines\n will be ignored that start with “@” until a line not starting with\n “@” is encountered. Lines will then be processed until another line\n starting with “@” is found or end-of-file is encountered. COMPOUND RESPONSE FILE EXAMPLE\n An example compound file ################# @ if > RUNNING TESTS USING RELEASE VERSION AND ifort options test -- release -- compiler ifort ################# @ gf > RUNNING TESTS USING RELEASE VERSION AND gfortran options test -- release -- compiler gfortran ################# @ nv > RUNNING TESTS USING RELEASE VERSION AND nvfortran options test -- release -- compiler nvfortran ################# @ nag > RUNNING TESTS USING RELEASE VERSION AND nagfor options test -- release -- compiler nagfor # ################# # OS - specific example : @ Linux @ install # # install executables in directory ( assuming install ( 1 ) exists ) # system mkdir - p ~/ . local / bin options run -- release T -- runner \"install -vbp -m 0711 -t ~/.local/bin\" @ install STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET # ################# @ fpm @ testall # !fpm test --compiler nvfortran !fpm test --compiler ifort !fpm test --compiler gfortran !fpm test --compiler nagfor STOP tests complete. Any additional parameters were ignored ################# Would be used like fpm @install fpm @nag -- fpm @testall NOTES The intel Fortran compiler now calls the response files \"indirect files\" and does not add the implied suffix \".rsp\" to the files anymore . It also allows the @NAME syntax anywhere on the command line , not just at the beginning . -- 20201212 AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: prototype character(len=*), intent(in), optional :: help_text (:) character(len=*), intent(in), optional :: version_text (:) character(len=*), intent(in), optional :: string character(len=*), intent(in), optional :: prefix integer, intent(out), optional :: ierr character(len=:), intent(out), optional, allocatable :: errmsg Contents Source Code set_args Source Code subroutine set_args ( prototype , help_text , version_text , string , prefix , ierr , errmsg ) ! ident_2=\"@(#) M_CLI2 set_args(3f) parse prototype string\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len =* ), intent ( in ), optional :: string character ( len =* ), intent ( in ), optional :: prefix integer , intent ( out ), optional :: ierr character ( len = :), intent ( out ), allocatable , optional :: errmsg character ( len = :), allocatable :: hold ! stores command line argument integer :: ibig character ( len = :), allocatable :: debug_mode debug_mode = upper ( get_env ( 'CLI_DEBUG_MODE' , 'FALSE' )) // ' ' select case ( debug_mode ( 1 : 1 )) case ( 'Y' , 'T' ) G_DEBUG = . true . end select G_response = CLI_RESPONSE_FILE G_options_only = . false . G_append = . true . G_passed_in = '' G_STOP = 0 G_STOP_MESSAGE = '' if ( present ( prefix )) then G_PREFIX = prefix else G_PREFIX = '' endif if ( present ( ierr )) then G_QUIET = . true . else G_QUIET = . false . endif ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) call wipe_dictionary () hold = '--version F --usage F --help F --version F ' // adjustl ( prototype ) call prototype_and_cmd_args_to_nlist ( hold , string ) if ( allocated ( G_RESPONSE_IGNORED )) then if ( G_DEBUG ) write ( * , gen ) 'SET_ARGS:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED if ( size ( unnamed ) /= 0 ) write ( * , * ) 'LOGIC ERROR' call split ( G_RESPONSE_IGNORED , unnamed ) endif if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif if (. not . allocated ( args )) then allocate ( character ( len = 0 ) :: args ( 0 )) endif call check_commandline ( help_text , version_text ) ! process --help, --version, --usage if ( present ( ierr )) then ierr = G_STOP endif if ( present ( errmsg )) then errmsg = G_STOP_MESSAGE endif end subroutine set_args","tags":"","loc":"proc/set_args.html"},{"title":"set_mode – M_CLI2","text":"public impure elemental subroutine set_mode(key, mode) NAME set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes\n(LICENSE:PD) SYNOPSIS subroutine set_mode(key,mode)\n\n character(len=*),intent(in) :: key\n logical,intent(in),optional :: mode DESCRIPTION Allow optional behaviors. OPTIONS KEY name of option o response_file - enable use of response file o ignorecase - ignore case in long key names o underdash - treat dash in keyname as an underscore o strict - allow boolean keys to be bundled , but requires a single dash prefix be used for short key names and long names to be prefixed with two dashes . MODE set to . true . to activate the optional mode . Set to . false . to deactivate the mode . It is . true . by default . EXAMPLE Sample program: program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ) , parameter :: all = ' (*(g0)) ' ! ! enable use of response files call set_mode ( ' response_file ' ) ! ! Any dash in a keyname is treated as an underscore call set_mode ( ' underdash ' ) ! ! The case of long keynames are ignored . ! Values and short names remain case - sensitive call set_mode ( ' ignorecase ' ) ! ! short single - character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keynames . call set_mode ( ' strict ' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F ' ) ! print all , ' --switch_X or -X ... ' , lget ( ' switch_X ' ) print all , ' --switch_Y or -Y ... ' , lget ( ' switch_Y ' ) print all , ' --ox or -O ... ' , lget ( ' ox ' ) print all , ' -o ... ' , lget ( ' o ' ) print all , ' -x ... ' , lget ( ' x ' ) print all , ' -t ... ' , lget ( ' t ' ) end program demo_set_mode AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key logical, intent(in), optional :: mode Contents Source Code set_mode Source Code elemental impure subroutine set_mode ( key , mode ) character ( len =* ), intent ( in ) :: key logical , intent ( in ), optional :: mode logical :: local_mode if ( present ( mode )) then local_mode = mode else local_mode = . true . endif select case ( lower ( key )) case ( 'response_file' , 'response file' ); CLI_RESPONSE_FILE = local_mode case ( 'debug' ); G_DEBUG = local_mode case ( 'ignorecase' ); G_IGNORECASE = local_mode case ( 'underdash' ); G_UNDERDASH = local_mode case ( 'strict' ); G_STRICT = local_mode case default call journal ( 'sc' , 'set_mode* unknown key name ' , key ) end select end subroutine set_mode","tags":"","loc":"proc/set_mode.html"},{"title":"cgets – M_CLI2","text":"public interface cgets Contents Module Procedures cgs cg Module Procedures private function cgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex, allocatable, (:) private function cg() Arguments None Return Value complex, allocatable, (:)","tags":"","loc":"interface/cgets.html"},{"title":"dgets – M_CLI2","text":"public interface dgets Contents Module Procedures dgs dg Module Procedures private function dgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp), allocatable, (:) private function dg() Arguments None Return Value real(kind=dp), allocatable, (:)","tags":"","loc":"interface/dgets.html"},{"title":"get_args – M_CLI2","text":"public interface get_args Contents Module Procedures get_anyarray_d Module Procedures private subroutine get_anyarray_d(keyword, darray, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword real(kind=dp), intent(out), allocatable :: darray (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args.html"},{"title":"get_args_fixed_length – M_CLI2","text":"public interface get_args_fixed_length Contents Module Procedures get_args_fixed_length_a_array Module Procedures private subroutine get_args_fixed_length_a_array(keyword, strings, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword character(len=*), allocatable :: strings (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args_fixed_length.html"},{"title":"get_args_fixed_size – M_CLI2","text":"public interface get_args_fixed_size Contents Module Procedures get_fixedarray_class Module Procedures private subroutine get_fixedarray_class(keyword, generic, delimiters) NAME get_args ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values when parsing command line arguments ( LICENSE : PD ) SYNOPSIS get_args(3f) and its convenience functions: use M_CLI2, only : get_args\n ! convenience functions\n use M_CLI2, only : dget, iget, lget, rget, sget, cget\n use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets\n\n subroutine get_args(name,value,delimiters)\n\n character(len=*),intent(in) :: name\n\n type( ${ TYPE } ),allocatable,intent(out) :: value(:)\n ! or\n type( ${ TYPE } ),allocatable,intent(out) :: value\n\n character(len=*),intent(in),optional :: delimiters\n\n where ${ TYPE } may be from the set\n {real,doubleprecision,integer,logical,complex,character(len=:)} DESCRIPTION GET_ARGS ( 3 f ) returns the value of keywords after SET_ARGS ( 3 f ) has been called . For fixed - length CHARACTER variables see GET_ARGS_FIXED_LENGTH ( 3 f ) . For fixed - size arrays see GET_ARGS_FIXED_SIZE ( 3 f ) . As a convenience multiple pairs of keywords and variables may be specified if and only if all the values are scalars and the CHARACTER variables are fixed - length or pre - allocated . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . The kind of the value is used to determine the type of returned value . May be a scalar or allocatable array . If type is CHARACTER the scalar must have an allocatable length . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . CONVENIENCE FUNCTIONS There are convenience functions that are replacements for calls to get_args ( 3 f ) for each supported default intrinsic type o scalars -- dget ( 3 f ) , iget ( 3 f ) , lget ( 3 f ) , rget ( 3 f ) , sget ( 3 f ) , cget ( 3 f ) o vectors -- dgets ( 3 f ) , igets ( 3 f ) , lgets ( 3 f ) , rgets ( 3 f ) , sgets ( 3 f ) , cgets ( 3 f ) D is for DOUBLEPRECISION , I for INTEGER , L for LOGICAL , R for REAL , S for string ( CHARACTER ) , and C for COMPLEX . If the functions are called with no argument they will return the UNNAMED array converted to the specified type . EXAMPLE Sample program: program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! DEFINE ARGS real :: x , y , z real , allocatable :: p ( : ) character ( len = : ) , allocatable :: title logical :: l , lbig ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings and use double - quotes ! o set all logical values to F or T . call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F - L F & & -- label \" \" & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( ' x ' , x , ' y ' , y , ' z ' , z ) call get_args ( ' l ' , l ) call get_args ( ' L ' , lbig ) ! ALLOCATABLE STRING call get_args ( ' title ' , title ) ! NON - ALLOCATABLE ARRAYS call get_args ( ' p ' , p ) ! USE VALUES write ( * , ' (1x,g0,\"=\",g0) ' ) ' x ' , x , ' y ' , y , ' z ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_get_args AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_length ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - length string when parsing command line ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_length(name,value)\n\n character(len=:),allocatable :: value\n character(len=*),intent(in),optional :: delimiters DESCRIPTION GET_ARGS_fixed_length ( 3 f ) returns the value of a string keyword when the string value is a fixed - length CHARACTER variable . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . Must be a fixed - length CHARACTER variable . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! DEFINE ARGS character ( len = 80 ) :: title call set_args ( ' & & -- title \" my title \" & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_length ( ' title ' , title ) ! USE VALUES write ( * , * ) ' title= ' , title end program demo_get_args_fixed_length AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_size ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - size array when parsing command line arguments ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_size(name,value)\n\n [real|doubleprecision|integer|logical|complex] :: value(NNN)\n or\n character(len=MMM) :: value(NNN)\n\n character(len=*),intent(in),optional :: delimiters DESCRIPTION GET_ARGS_FIXED_SIZE ( 3 f ) returns the value of keywords for fixed - size arrays after SET_ARGS ( 3 f ) has been called . On input on the command line all values of the array must be specified . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned values . The kind of the value is used to determine the type of returned value . Must be a fixed - size array . If type is CHARACTER the length must also be fixed . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0 . 0 d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ) , lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings ! o set all logical values to F or T . call set_args ( ' & & - x 10 . 0 , 20 . 0 & & - y 11 . 0 , 22 . 0 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F , T , F , T - L T , F , T , F & & -- cmp 111 , 222 . 0 , 333 . 0 e0 , 4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( ' x ' , x ) call get_args_fixed_size ( ' y ' , y ) call get_args_fixed_size ( ' p ' , p ) call get_args_fixed_size ( ' title ' , title ) call get_args_fixed_size ( ' l ' , l ) call get_args_fixed_size ( ' L ' , lbig ) call get_args_fixed_size ( ' cmp ' , cmp ) ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig write ( * , * ) ' cmp= ' , cmp end program demo_get_args_fixed_size Results: AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword class(*) :: generic (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args_fixed_size.html"},{"title":"igets – M_CLI2","text":"public interface igets Contents Module Procedures igs ig Module Procedures private function igs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer, allocatable, (:) private function ig() Arguments None Return Value integer, allocatable, (:)","tags":"","loc":"interface/igets.html"},{"title":"lgets – M_CLI2","text":"public interface lgets Contents Module Procedures lgs lg Module Procedures private function lgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical, allocatable, (:) private function lg() Arguments None Return Value logical, allocatable, (:)","tags":"","loc":"interface/lgets.html"},{"title":"rgets – M_CLI2","text":"public interface rgets Contents Module Procedures rgs rg Module Procedures private function rgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real, allocatable, (:) private function rg() Arguments None Return Value real, allocatable, (:)","tags":"","loc":"interface/rgets.html"},{"title":"sgets – M_CLI2","text":"public interface sgets Contents Module Procedures sgs sg Module Procedures private function sgs(n, delims) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n character(len=*), intent(in), optional :: delims Return Value character(len=:), allocatable, (:) private function sg() Arguments None Return Value character(len=:), allocatable, (:)","tags":"","loc":"interface/sgets.html"},{"title":"parse – M_CLI2","text":"subroutine parse() Uses M_CLI2 PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY Arguments None Contents Variables cmd help_text version_text Source Code parse Variables Type Visibility Attributes Name Initial character(len=*), public, parameter :: cmd = ' -x 1 -y 2 -z 3 --point -1,-2,-3 --title \"my title\" -l F -L F ' character(len=:), public, allocatable :: help_text (:) DEFINE COMMAND PROTOTYPE\n o All parameters must be listed with a default value\n o string values must be double-quoted\n o numeric lists must be comma-delimited. No spaces are allowed\n o long keynames must be all lowercase character(len=:), public, allocatable :: version_text (:) DEFINE COMMAND PROTOTYPE\n o All parameters must be listed with a default value\n o string values must be double-quoted\n o numeric lists must be comma-delimited. No spaces are allowed\n o long keynames must be all lowercase Source Code subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse","tags":"","loc":"proc/parse.html"},{"title":"my_run – M_CLI2","text":"subroutine my_run(x, y, z, title, l, l_) Arguments Type Intent Optional Attributes Name real, intent(in) :: x real, intent(in) :: y real, intent(in) :: z character(len=*), intent(in) :: title logical, intent(in) :: l logical, intent(in) :: l_ Contents Source Code my_run Source Code subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run","tags":"","loc":"proc/my_run.html"},{"title":"parse – M_CLI2","text":"subroutine parse(name) Uses M_CLI2 Arguments Type Intent Optional Attributes Name character(len=*) :: name Contents Variables help_text version_text Source Code parse Variables Type Visibility Attributes Name Initial character(len=:), public, allocatable :: help_text (:) character(len=:), public, allocatable :: version_text (:) Source Code subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse","tags":"","loc":"proc/parse~2.html"},{"title":"M_CLI2 – M_CLI2","text":"NAME M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument\nparsing using a prototype command\n(LICENSE:PD) SYNOPSIS Available procedures and variables: use M_CLI2, only : set_args, get_args, specified, set_mode\n use M_CLI2, only : unnamed, remaining, args\n use M_CLI2, only : get_args_fixed_length, get_args_fixed_size\n ! convenience functions\n use M_CLI2, only : dget, iget, lget, rget, sget, cget\n use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets DESCRIPTION Allow for command line parsing much like standard Unix command line parsing using a simple prototype . Typically one call to SET_ARGS ( 3 f ) is made to define the command arguments , set default values and parse the command line . Then a call is made to the convenience commands based on GET_ARGS ( 3 f ) for each command keyword to obtain the argument values . The documentation for SET_ARGS ( 3 f ) and GET_ARGS ( 3 f ) provides further details . EXAMPLE Sample typical minimal usage program minimal use M_CLI2 , only : set_args , lget , rget , filenames => unnamed implicit none real :: x , y integer :: i call set_args ( ' -y 0.0 -x 0.0 --debug F ' ) x = rget ( ' x ' ) y = rget ( ' y ' ) if ( lget ( ' debug ' )) then write ( * , * ) ' X= ' , x write ( * , * ) ' Y= ' , y write ( * , * ) ' ATAN2(Y,X)= ' , atan2 ( x = x , y = y ) else write ( * , * ) atan2 ( x = x , y = y ) endif if ( size ( filenames ) > 0 ) then write ( * , ' (g0) ' ) ' filenames: ' write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program minimal Sample program using get_args() and variants program demo_M_CLI2 use M_CLI2 , only : set_args , get_args use M_CLI2 , only : filenames => unnamed use M_CLI2 , only : get_args_fixed_length , get_args_fixed_size implicit none integer :: i integer , parameter :: dp = kind ( 0 . 0 d0 ) ! ! DEFINE ARGS real :: x , y , z real ( kind = dp ) , allocatable :: point ( : ) logical :: l , lbig logical , allocatable :: logicals ( : ) character ( len = : ) , allocatable :: title ! VARIABLE LENGTH character ( len = 40 ) :: label ! FIXED LENGTH real :: p ( 3 ) ! FIXED SIZE logical :: logi ( 3 ) ! FIXED SIZE ! ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o set a value for all keywords . ! o double - quote strings ! o set all logical values to F or T . ! o value delimiter is comma , colon , or space call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 - 2 - 3 & & -- point 11 . 11 , 22 . 22 , 33 . 33 e0 & & -- title \" my title \" - l F - L F & & -- logicals F F F F F & & -- logi F T F & & -- label \" \" & ! note space between quotes is required & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args ( ' x ' , x ) ! SCALARS call get_args ( ' y ' , y ) call get_args ( ' z ' , z ) call get_args ( ' l ' , l ) call get_args ( ' L ' , lbig ) call get_args ( ' title ' , title ) ! ALLOCATABLE STRING call get_args ( ' point ' , point ) ! ALLOCATABLE ARRAYS call get_args ( ' logicals ' , logicals ) ! ! for NON - ALLOCATABLE VARIABLES ! for non - allocatable string call get_args_fixed_length ( ' label ' , label ) ! for non - allocatable arrays call get_args_fixed_size ( ' p ' , p ) call get_args_fixed_size ( ' logi ' , logi ) ! ! USE VALUES write ( * , * ) ' x= ' , x , ' y= ' , y , ' z= ' , z , x + y + z write ( * , * ) ' p= ' , p write ( * , * ) ' point= ' , point write ( * , * ) ' title= ' , title write ( * , * ) ' label= ' , label write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig write ( * , * ) ' logicals= ' , logicals write ( * , * ) ' logi= ' , logi ! ! unnamed strings ! if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif ! end program demo_M_CLI2 AUTHOR John S. Urban, 2019 LICENSE Public Domain Uses iso_fortran_env Contents Variables CLI_RESPONSE_FILE args remaining unnamed Interfaces cgets dgets get_args get_args_fixed_length get_args_fixed_size igets lgets rgets sgets Functions cget dget get_subcommand iget lget rget sget specified Subroutines print_dictionary set_args set_mode Variables Type Visibility Attributes Name Initial logical, public, save :: CLI_RESPONSE_FILE = .false. character(len=:), public, allocatable :: args (:) character(len=:), public, allocatable :: remaining character(len=:), public, allocatable :: unnamed (:) Interfaces public interface cgets private function cgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex, allocatable, (:) private function cg() Arguments None Return Value complex, allocatable, (:) public interface dgets private function dgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp), allocatable, (:) private function dg() Arguments None Return Value real(kind=dp), allocatable, (:) public interface get_args private subroutine get_anyarray_d(keyword, darray, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword real(kind=dp), intent(out), allocatable :: darray (:) character(len=*), intent(in), optional :: delimiters public interface get_args_fixed_length private subroutine get_args_fixed_length_a_array(keyword, strings, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword character(len=*), allocatable :: strings (:) character(len=*), intent(in), optional :: delimiters public interface get_args_fixed_size private subroutine get_fixedarray_class(keyword, generic, delimiters) NAME get_args ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values when parsing command line arguments ( LICENSE : PD ) SYNOPSIS get_args(3f) and its convenience functions: use M_CLI2, only : get_args\n ! convenience functions\n use M_CLI2, only : dget, iget, lget, rget, sget, cget\n use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets\n\n subroutine get_args(name,value,delimiters)\n\n character(len=*),intent(in) :: name\n\n type( ${ TYPE } ),allocatable,intent(out) :: value(:)\n ! or\n type( ${ TYPE } ),allocatable,intent(out) :: value\n\n character(len=*),intent(in),optional :: delimiters\n\n where ${ TYPE } may be from the set\n {real,doubleprecision,integer,logical,complex,character(len=:)} DESCRIPTION GET_ARGS ( 3 f ) returns the value of keywords after SET_ARGS ( 3 f ) has been called . For fixed - length CHARACTER variables see GET_ARGS_FIXED_LENGTH ( 3 f ) . For fixed - size arrays see GET_ARGS_FIXED_SIZE ( 3 f ) . As a convenience multiple pairs of keywords and variables may be specified if and only if all the values are scalars and the CHARACTER variables are fixed - length or pre - allocated . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . The kind of the value is used to determine the type of returned value . May be a scalar or allocatable array . If type is CHARACTER the scalar must have an allocatable length . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . CONVENIENCE FUNCTIONS There are convenience functions that are replacements for calls to get_args ( 3 f ) for each supported default intrinsic type o scalars -- dget ( 3 f ) , iget ( 3 f ) , lget ( 3 f ) , rget ( 3 f ) , sget ( 3 f ) , cget ( 3 f ) o vectors -- dgets ( 3 f ) , igets ( 3 f ) , lgets ( 3 f ) , rgets ( 3 f ) , sgets ( 3 f ) , cgets ( 3 f ) D is for DOUBLEPRECISION , I for INTEGER , L for LOGICAL , R for REAL , S for string ( CHARACTER ) , and C for COMPLEX . If the functions are called with no argument they will return the UNNAMED array converted to the specified type . EXAMPLE Sample program: program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! DEFINE ARGS real :: x , y , z real , allocatable :: p ( : ) character ( len = : ) , allocatable :: title logical :: l , lbig ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings and use double - quotes ! o set all logical values to F or T . call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F - L F & & -- label \" \" & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( ' x ' , x , ' y ' , y , ' z ' , z ) call get_args ( ' l ' , l ) call get_args ( ' L ' , lbig ) ! ALLOCATABLE STRING call get_args ( ' title ' , title ) ! NON - ALLOCATABLE ARRAYS call get_args ( ' p ' , p ) ! USE VALUES write ( * , ' (1x,g0,\"=\",g0) ' ) ' x ' , x , ' y ' , y , ' z ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_get_args AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_length ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - length string when parsing command line ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_length(name,value)\n\n character(len=:),allocatable :: value\n character(len=*),intent(in),optional :: delimiters DESCRIPTION GET_ARGS_fixed_length ( 3 f ) returns the value of a string keyword when the string value is a fixed - length CHARACTER variable . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . Must be a fixed - length CHARACTER variable . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! DEFINE ARGS character ( len = 80 ) :: title call set_args ( ' & & -- title \" my title \" & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_length ( ' title ' , title ) ! USE VALUES write ( * , * ) ' title= ' , title end program demo_get_args_fixed_length AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_size ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - size array when parsing command line arguments ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_size(name,value)\n\n [real|doubleprecision|integer|logical|complex] :: value(NNN)\n or\n character(len=MMM) :: value(NNN)\n\n character(len=*),intent(in),optional :: delimiters DESCRIPTION GET_ARGS_FIXED_SIZE ( 3 f ) returns the value of keywords for fixed - size arrays after SET_ARGS ( 3 f ) has been called . On input on the command line all values of the array must be specified . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned values . The kind of the value is used to determine the type of returned value . Must be a fixed - size array . If type is CHARACTER the length must also be fixed . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0 . 0 d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ) , lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings ! o set all logical values to F or T . call set_args ( ' & & - x 10 . 0 , 20 . 0 & & - y 11 . 0 , 22 . 0 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F , T , F , T - L T , F , T , F & & -- cmp 111 , 222 . 0 , 333 . 0 e0 , 4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( ' x ' , x ) call get_args_fixed_size ( ' y ' , y ) call get_args_fixed_size ( ' p ' , p ) call get_args_fixed_size ( ' title ' , title ) call get_args_fixed_size ( ' l ' , l ) call get_args_fixed_size ( ' L ' , lbig ) call get_args_fixed_size ( ' cmp ' , cmp ) ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig write ( * , * ) ' cmp= ' , cmp end program demo_get_args_fixed_size Results: AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword class(*) :: generic (:) character(len=*), intent(in), optional :: delimiters public interface igets private function igs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer, allocatable, (:) private function ig() Arguments None Return Value integer, allocatable, (:) public interface lgets private function lgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical, allocatable, (:) private function lg() Arguments None Return Value logical, allocatable, (:) public interface rgets private function rgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real, allocatable, (:) private function rg() Arguments None Return Value real, allocatable, (:) public interface sgets private function sgs(n, delims) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n character(len=*), intent(in), optional :: delims Return Value character(len=:), allocatable, (:) private function sg() Arguments None Return Value character(len=:), allocatable, (:) Functions public function cget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex public function dget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp) public function get_subcommand () result(sub) Sample program: Read more… Arguments None Return Value character(len=:), allocatable public function iget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer public function lget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical public function rget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real public function sget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value character(len=:), allocatable public impure elemental function specified (key) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key Return Value logical Subroutines public subroutine print_dictionary (header, stop) Typical usage: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in), optional :: header logical, intent(in), optional :: stop public subroutine set_args (prototype, help_text, version_text, string, prefix, ierr, errmsg) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: prototype character(len=*), intent(in), optional :: help_text (:) character(len=*), intent(in), optional :: version_text (:) character(len=*), intent(in), optional :: string character(len=*), intent(in), optional :: prefix integer, intent(out), optional :: ierr character(len=:), intent(out), optional, allocatable :: errmsg public impure elemental subroutine set_mode (key, mode) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key logical, intent(in), optional :: mode","tags":"","loc":"module/m_cli2.html"},{"title":"demo3 – M_CLI2","text":"Uses M_CLI2 example of basic use\n! JUST THE BARE ESSENTIALS Contents Variables l size title x y Source Code demo3 Variables Type Attributes Name Initial logical :: l real :: size character(len=:), allocatable :: title integer :: x integer :: y Source Code program demo3 !! example of **basic** use !*! JUST THE BARE ESSENTIALS use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size:s 12.34567 -l F --title:t \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"program/demo3.html"},{"title":"demo11 – M_CLI2","text":"Uses iso_fortran_env @(#) examples of validating values with ALL(3f) and ANY(3f) Contents Variables dot i name readme string Derived Types point Source Code demo11 Variables Type Attributes Name Initial type( point ) :: dot integer :: i character(len=:), allocatable :: name character(len=80) :: readme character(len=:), allocatable :: string Derived Types type :: point Components Type Visibility Attributes Name Initial character(len=20), public :: color = 'red' integer, public :: x = 0 integer, public :: y = 0 Source Code program demo11 !! @(#) examples of validating values with ALL(3f) and ANY(3f) use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT implicit none type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point type ( point ) :: dot ; namelist / nml_dot / dot character ( len = :), allocatable :: name character ( len = :), allocatable :: string character ( len = 80 ) :: readme !(3) integer :: i ! M_CLI2 does not have validators except for SPECIFIED(3f) and ! a check whether the input conforms to the type with get_args(3f) ! and the convenience functions like inum(3f). But Fortran already ! has powerful validation capabilities, especially with the use ! of logical expressions, and ANY(3f) and ALL(3f). ! A somewhat contrived example of using ALL(3f): ! even number from 10 to 30 inclusive do i = 1 , 100 if ( all ([ i >= 10 , i <= 30 ,( i / 2 ) * 2 == i ])) then write ( * , * ) 'good' , i endif enddo ! an example of using ANY(3f) ! matched name = 'red' if ( any ( name == [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ])) then write ( * , * ) 'matches ' , name endif ! not matched name = 'teal' if ( any ( name == [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ])) then write ( * , * ) 'matches ' , name endif ! and even user-defined types can be processed by reading the input ! as a string and using a NAMELIST(3f) group to convert it. Note that ! if input values are strings that have to be quoted (ie. more than one ! word) or contain characters special to the shell that how you have to ! quote the command line can get complicated. string = '10,20,\"green\"' readme = '&nml_dot dot=' // string // '/' ! some compilers might require the input to be on three lines !readme=[ character(len=80) ::& !'&nml_dot', & !'dot='//string//' ,', & !'/'] read ( readme , nml = nml_dot ) write ( * , * ) dot % x , dot % y , dot % color ! or write ( * , nml_dot ) ! Hopefully it is obvious how the options can be read from values gotten ! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f) ! in the first case, so this example just uses simple declarations to highlight ! some useful Fortran expressions that can be useful for validating the input ! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups. ! another alternative would be to validate expressions from strings using M_calculator(3f) ! but I find it easier to validate the values using regular Fortran code than doing it ! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by ! M_CLI2(3f) doing validation in the input forms themselves would be more desirable. end program demo11","tags":"","loc":"program/demo11.html"},{"title":"demo10 – M_CLI2","text":"Uses M_CLI2 @(#) full usage and even equivalencing\nWHEN DEFINING THE PROTOTYPE SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES\nALL DONE CRACKING THE COMMAND LINE. GET THE VALUES\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables i l l_ p point title x y z Source Code demo10 Variables Type Attributes Name Initial integer :: i DECLARE “ARGS” logical :: l logical :: l_ real :: p (3) real :: point (3) character(len=80) :: title real :: x real :: y real :: z Source Code program demo10 !! @(#) full usage and even equivalencing use M_CLI2 , only : set_args , get_args , unnamed use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : specified ! only needed if equivalence keynames implicit none integer :: i !! DECLARE \"ARGS\" real :: x , y , z real :: point ( 3 ), p ( 3 ) character ( len = 80 ) :: title logical :: l , l_ equivalence ( point , p ) !! WHEN DEFINING THE PROTOTYPE ! o All parameters must be listed with a default value ! o string values must be double-quoted ! o numeric lists must be comma-delimited. No spaces are allowed ! o long keynames must be all lowercase !! SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES call set_args ( '-x 1 -y 2 -z 3 --point -1,-2,-3 --p -1,-2,-3 --title \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) ! note these are equivalenced so one of the calls must be conditional call get_args_fixed_size ( 'point' , point ) if ( specified ( 'p' )) call get_args_fixed_size ( 'p' , p ) ! if for some reason you want to use a fixed-length string use ! get_args_fixed_length(3f) instead of get_args(3f) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z write ( * , * ) 'point=' , point , 'p=' , p write ( * , * ) 'title=' , trim ( title ) write ( * , * ) 'l=' , l , 'L=' , l_ ! ! the optional unnamed values on the command line are ! accumulated in the character array \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif end program demo10","tags":"","loc":"program/demo10.html"},{"title":"demo4 – M_CLI2","text":"Uses M_CLI2 @(#) COMPLEX type values Contents Variables aarr form forms three x y z Source Code demo4 Variables Type Attributes Name Initial complex, allocatable :: aarr (:) character(len=*), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character(len=*), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' complex :: three (3) complex :: x complex :: y complex :: z Source Code program demo4 !! @(#) _COMPLEX_ type values use M_CLI2 , only : set_args , get_args , get_args_fixed_size implicit none complex :: x , y , z ! scalars complex , allocatable :: aarr (:) ! allocatable array complex :: three ( 3 ) ! fixed-size array ! formats to pretty-print a complex value and small complex vector character ( len =* ), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character ( len =* ), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' ! COMPLEX VALUES ! ! o parenthesis are optional and are ignored in complex values. ! ! o base#value is acceptable for base 2 to 32 for whole numbers, ! which is why \"i\" is not allowed as a suffix on imaginary values ! (because some bases include \"i\" as a digit). ! ! o normally arrays are allocatable. if a fixed size array is used ! call get_args_fixed_size(3f) and all the values must be ! specified. This is useful when you have something that requires ! a specific number of values. Perhaps a point in space must always ! have three values, for example. ! ! o default delimiters are whitespace, comma and colon. Note that ! whitespace delimiters should not be used in the definition, ! but are OK on command input if the entire parameter value is ! quoted. Using space delimiters in the prototype definition is ! not supported (but works) and requires that the value be quoted ! on input in common shells. Adjacent delimiters are treated as ! a single delimiter. ! call set_args ( '-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444' ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'three' , three ) call get_args ( 'aarr' , aarr ) write ( * , form ) x , y , z , x + y + z write ( * , forms ) three write ( * , forms ) aarr end program demo4","tags":"","loc":"program/demo4.html"},{"title":"demo14 – M_CLI2","text":"Uses M_CLI2 @(#) ignorecase mode long keynames are internally converted to lowercase\nwhen ignorecase mode is on these are equivalent demo14 --longName\ndemo14 --longname\ndemo14 --LongName Values and short names remain case-sensitive Contents Variables all Source Code demo14 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo14 !> @(#) ignorecase mode !! !! long keynames are internally converted to lowercase !! when ignorecase mode is on these are equivalent !! !! demo14 --longName !! demo14 --longname !! demo14 --LongName !! !! Values and short names remain case-sensitive !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'ignorecase' ) call set_args ( ' --longName:N F ' ) print all , '--longName or -N ... ' , lget ( 'longName' ) end program demo14","tags":"","loc":"program/demo14.html"},{"title":"demo3 – M_CLI2","text":"Uses M_CLI2 @(#) example of basic use using just the bare essentials Contents Variables l size title x y Source Code demo3 Variables Type Attributes Name Initial logical :: l real :: size character(len=:), allocatable :: title integer :: x integer :: y Source Code program demo3 !! @(#) example of **basic** use using just the bare essentials use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! Done. all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"program/demo3~2.html"},{"title":"demo2 – M_CLI2","text":"Uses M_CLI2 @(#) all parsing and help and version information in a contained procedure.\nDEFINE AND PARSE COMMAND LINE ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.\nTHE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE\nACCUMULATED IN THE CHARACTER ARRAY “UNNAMED” Contents Variables i l l_ point title x y z Subroutines parse Source Code demo2 Variables Type Attributes Name Initial integer :: i DEFINE “ARGS” VALUES logical :: l logical :: l_ real :: point (3) character(len=80) :: title integer :: x integer :: y integer :: z Subroutines subroutine parse () PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY Arguments None Source Code program demo2 !! @(#) all parsing and **help** and **version** information in a contained procedure. use M_CLI2 , only : unnamed implicit none integer :: i !! DEFINE \"ARGS\" VALUES integer :: x , y , z real :: point ( 3 ) character ( len = 80 ) :: title logical :: l , l_ call parse () !! DEFINE AND PARSE COMMAND LINE !! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM. write ( * , * ) x + y + z write ( * , * ) point * 2 write ( * , * ) title write ( * , * ) l , l_ !! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE !! ACCUMULATED IN THE CHARACTER ARRAY \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif contains subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse end program demo2","tags":"","loc":"program/demo2.html"},{"title":"demo15 – M_CLI2","text":"Uses M_CLI2 @(#) strict mode In strict mode short single-character names may be bundled but it is\nrequired that a single dash is used, where normally single and double\ndashes are equivalent. demo15 -o -t -x\ndemo15 -otx\ndemo15 -xto Only Boolean keynames may be bundled together Contents Variables all Source Code demo15 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo15 !> @(#) strict mode !! !! In strict mode short single-character names may be bundled but it is !! required that a single dash is used, where normally single and double !! dashes are equivalent. !! !! demo15 -o -t -x !! demo15 -otx !! demo15 -xto !! !! Only Boolean keynames may be bundled together !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'strict' ) call set_args ( ' -o F -t F -x F --ox F' ) print all , 'o=' , lget ( 'o' ), ' t=' , lget ( 't' ), ' x=' , lget ( 'x' ), ' ox=' , lget ( 'ox' ) end program demo15","tags":"","loc":"program/demo15.html"},{"title":"demo6 – M_CLI2","text":"Uses M_CLI2 @(#) SUBCOMMANDS For a command with subcommands like git(1) you can call this program\nwhich has two subcommands (run, test), like this: demo6 –help\n demo6 run -x -y -z -title -l -L\n demo6 test -title -l -L -testname\n demo6 run –help Contents Variables help_text l l_ name testname title version_text Subroutines my_run Source Code demo6 Variables Type Attributes Name Initial character(len=:), allocatable :: help_text (:) logical :: l logical :: l_ character(len=:), allocatable :: name character(len=80) :: testname character(len=80) :: title character(len=:), allocatable :: version_text (:) Subroutines subroutine my_run (x, y, z, title, l, l_) Arguments Type Intent Optional Attributes Name real, intent(in) :: x real, intent(in) :: y real, intent(in) :: z character(len=*), intent(in) :: title logical, intent(in) :: l logical, intent(in) :: l_ Source Code program demo6 !! @(#) SUBCOMMANDS !! !! For a command with subcommands like git(1) you can call this program !! which has two subcommands (run, test), like this: !! !! demo6 --help !! demo6 run -x -y -z -title -l -L !! demo6 test -title -l -L -testname !! demo6 run --help !! use M_CLI2 , only : set_args , get_args , get_args_fixed_length , get_subcommand use M_CLI2 , only : rget , sget , lget use M_CLI2 , only : CLI_RESPONSE_FILE implicit none character ( len = :), allocatable :: name ! the subcommand name character ( len = :), allocatable :: version_text (:), help_text (:) ! define some values to use as arguments character ( len = 80 ) :: title , testname logical :: l , l_ version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo6 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] CLI_RESPONSE_FILE = . true . ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () ! define commands and parse command line and set help text and process command select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , help_text , version_text ) ! example using convenience functions to retrieve values and pass them ! to a routine call my_run ( rget ( 'x' ), rget ( 'y' ), rget ( 'z' ), sget ( 'title' ), lget ( 'l' ), lget ( 'L' )) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( '--title \"my title\" -l F -L F --testname \"Test\"' , help_text , version_text ) ! use get_args(3f) to extract values and use them call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) ! all done cracking the command line. use the values in your program. write ( * , * ) 'command was ' , name write ( * , * ) 'title .... ' , trim ( title ) write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , trim ( testname ) case ( '' ) ! general help for \"demo6 --help\" help_text = [ character ( len = 80 ) :: & ' General help describing the ' , & ' program. ' , & '' ] call set_args ( ' ' , help_text , version_text ) ! process help and version case default call set_args ( ' ' , help_text , version_text ) ! process help and version write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' end select contains subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run end program demo6","tags":"","loc":"program/demo6.html"},{"title":"demo12 – M_CLI2","text":"Uses M_CLI2 @(#) using the convenience functions\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables x y z Source Code demo12 Variables Type Attributes Name Initial real :: x ENABLE USING RESPONSE FILES real :: y ENABLE USING RESPONSE FILES real :: z ENABLE USING RESPONSE FILES Source Code program demo12 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , rget implicit none real :: x , y , z !! ENABLE USING RESPONSE FILES call set_mode ( 'response file' ) call set_args ( '-x 1.1 -y 2e3 -z -3.9 ' ) x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z end program demo12","tags":"","loc":"program/demo12.html"},{"title":"demo7 – M_CLI2","text":"Uses M_CLI2 @(#) controlling array delimiter characters Contents Variables characters complexs doubles dp fixed flen integers normal reals Source Code demo7 Variables Type Attributes Name Initial character(len=:), allocatable :: characters (:) complex, allocatable :: complexs (:) real(kind=dp), allocatable :: doubles (:) integer, parameter :: dp = kind(0.0d0) character(len=4) :: fixed (2) character(len=20), allocatable :: flen (:) integer, allocatable :: integers (:) real(kind=dp), allocatable :: normal (:) real, allocatable :: reals (:) Source Code program demo7 !! @(#) controlling array delimiter characters use M_CLI2 , only : set_args , get_args , get_args_fixed_size , get_args_fixed_length implicit none integer , parameter :: dp = kind ( 0.0d0 ) character ( len = 20 ), allocatable :: flen (:) ! allocatable array with fixed length character ( len = 4 ) :: fixed ( 2 ) ! fixed-size array wih fixed length integer , allocatable :: integers (:) real , allocatable :: reals (:) real ( kind = dp ), allocatable :: doubles (:) real ( kind = dp ), allocatable :: normal (:) complex , allocatable :: complexs (:) character ( len = :), allocatable :: characters (:) ! allocatable array with allocatable length ! ARRAY DELIMITERS ! ! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f) ! call set_args ( '-flen A,B,C -fixed X,Y --integers z --reals 111/222/333 -normal , --doubles | --complexs 0!0 --characters @' ) call get_args ( 'integers' , integers , delimiters = 'abcdefghijklmnopqrstuvwxyz' ) call get_args ( 'reals' , reals , delimiters = '/' ) call get_args ( 'doubles' , doubles , delimiters = '|' ) call get_args ( 'complexs' , complexs , delimiters = '!' ) call get_args ( 'normal' , normal ) call get_args ( 'characters' , characters , delimiters = '@' ) call get_args_fixed_length ( 'flen' , flen ) call get_args_fixed_size ( 'fixed' , fixed ) ! fixed length and fixed size array write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( flen ), 'flen=' , flen write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( characters ), 'characters=' , characters write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( integers ), 'integers=' , integers write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( reals ), 'reals=' , reals write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( doubles ), 'doubles=' , doubles write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( complexs ), 'complexs=' , complexs write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( normal ), 'normal=' , normal write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( fixed ), 'fixed=' , fixed end program demo7","tags":"","loc":"program/demo7.html"},{"title":"demo8 – M_CLI2","text":"Uses M_CLI2 @(#) Sometimes you can put multiple values on getargs(3f) Contents Variables l pairs size title x y Source Code demo8 Variables Type Attributes Name Initial logical :: l character(len=*), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' real :: size character(len=80) :: title integer :: x integer :: y Source Code program demo8 !! @(#) Sometimes you can put multiple values on getargs(3f) use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = 80 ) :: title character ( len =* ), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' ! DEFINE COMMAND AND PARSE COMMAND LINE ! set all values, double-quote strings call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! GET THE VALUES ! only fixed scalar values (including only character variables that ! are fixed length) may be combined in one GET_ARGS(3f) call call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size , 'title' , title ) ! USE THE VALUES write ( * , fmt = pairs ) 'X' , x , 'Y' , y , 'size' , size , 'L' , l , 'TITLE' , title end program demo8","tags":"","loc":"program/demo8.html"},{"title":"demo13 – M_CLI2","text":"Uses M_CLI2 @(#) underdash mode\nAny dash in a key name is treated as an underscore\nwhen underdash mode is on demo13 --switch-X\ndemo13 --switch_X are equivalent when this mode is on Contents Variables all Source Code demo13 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo13 !> @(#) underdash mode !! Any dash in a key name is treated as an underscore !! when underdash mode is on !! !! demo13 --switch-X !! demo13 --switch_X !! !! are equivalent when this mode is on !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'underdash' ) call set_args ( ' --switch_X:X F --switch-Y:Y F ' ) print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) end program demo13","tags":"","loc":"program/demo13.html"},{"title":"demo9 – M_CLI2","text":"Uses M_CLI2 @(#) long and short names using –LONGNAME:SHORTNAME When all keys have a long and short name “strict mode” is invoked where\n “-” is required for short names; and Boolean values may be bundled\n together. For example: demo9 -XYZ Contents Variables all Source Code demo9 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo9 !> @(#) long and short names using --LONGNAME:SHORTNAME !! !! When all keys have a long and short name \"strict mode\" is invoked where !! \"-\" is required for short names; and Boolean values may be bundled !! together. For example: !! !! demo9 -XYZ !! use M_CLI2 , only : set_args , sget , rget , lget implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_args ( ' & & --length:l 10 & & --height:h 12.45 & & --switchX:X F & & --switchY:Y F & & --switchZ:Z F & & --title:T \"my title\"' ) print all , '--length or -l .... ' , rget ( 'length' ) print all , '--height or -h .... ' , rget ( 'height' ) print all , '--switchX or -X ... ' , lget ( 'switchX' ) print all , '--switchY or -Y ... ' , lget ( 'switchY' ) print all , '--switchZ or -Z ... ' , lget ( 'switchZ' ) print all , '--title or -T ..... ' , sget ( 'title' ) end program demo9","tags":"","loc":"program/demo9.html"},{"title":"demo5 – M_CLI2","text":"Uses M_CLI2 @(#) CHARACTER type values\ncharacter variables have a length, unlike number variables Contents Variables fmt Source Code demo5 Variables Type Attributes Name Initial character(len=*), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' Source Code program demo5 !! @(#) _CHARACTER_ type values !! character variables have a length, unlike number variables use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : sget , sgets implicit none character ( len =* ), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' call set_args ( ' & & --alloc_len_scalar \" \" --fx_len_scalar \" \" & & --alloc_array \"A,B,C\" & & --fx_size_fx_len \"A,B,C\" & & --fx_len_alloc_array \"A,B,C\" & & ' ) block ! you just need get_args(3f) for general scalars or arrays ! variable length scalar character ( len = :), allocatable :: alloc_len_scalar ! variable array size and variable length character ( len = :), allocatable :: alloc_array (:) call get_args ( 'alloc_len_scalar' , alloc_len_scalar ) write ( * , fmt ) 'allocatable length scalar=' , alloc_len_scalar ,& & len ( alloc_len_scalar ) call get_args ( 'alloc_array' , alloc_array ) write ( * , fmt ) 'allocatable array= ' , alloc_array endblock ! less commonly, if length or size is fixed, use a special function block character ( len = 19 ), allocatable :: fx_len_alloc_array (:) call get_args_fixed_length ( 'fx_len_alloc_array' , fx_len_alloc_array ) write ( * , fmt ) 'fixed length allocatable array=' , fx_len_alloc_array endblock block character ( len = 19 ) :: fx_len_scalar call get_args_fixed_length ( 'fx_len_scalar' , fx_len_scalar ) write ( * , fmt ) 'fixed length scalar= ' , fx_len_scalar endblock block character ( len = 19 ) :: fx_size_fx_len ( 3 ) call get_args_fixed_size ( 'fx_size_fx_len' , fx_size_fx_len ) write ( * , fmt ) 'fixed size fixed length= ' , fx_size_fx_len endblock block ! or (recommended) set to an allocatable array and check size and ! length returned character ( len = :), allocatable :: a ! variable length scalar character ( len = :), allocatable :: arr (:) ! variable array size and variable length call get_args ( 'fx_size_fx_len' , arr ) ! or arr = sgets ( 'fx_size_fx_len' ) if ( size ( arr ) /= 3 ) write ( * , * ) 'not right size' if ( len ( arr ) > 19 ) write ( * , * ) 'longer than wanted' call get_args ( 'fx_len_scalar' , a ) !or a = sget ( 'fx_len_scalar' ) if ( len ( a ) > 19 ) write ( * , * ) 'too long' write ( * , * ) a , len ( a ) write ( * , * ) arr , len ( arr ), size ( arr ) endblock end program demo5","tags":"","loc":"program/demo5.html"},{"title":"demo1 – M_CLI2","text":"Uses M_CLI2 @(#) using the convenience functions\nDECLARE “ARGS”\nSET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES\nALL DONE CRACKING THE COMMAND LINE. GET THE VALUES\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables anytitle l lupper point title x y z Source Code demo1 Variables Type Attributes Name Initial character(len=:), allocatable :: anytitle logical :: l logical :: lupper real :: point (3) character(len=:), allocatable :: title real :: x real :: y real :: z Source Code program demo1 !! @(#) using the convenience functions use M_CLI2 , only : set_args , get_args_fixed_size , set_mode use M_CLI2 , only : dget , iget , lget , rget , sget , cget ! for scalars use M_CLI2 , only : dgets , igets , lgets , rgets , sgets , cgets ! for allocatable arrays implicit none !! DECLARE \"ARGS\" real :: x , y , z , point ( 3 ) character ( len = :), allocatable :: title , anytitle logical :: l , lupper call set_mode ( 'response_file' ) !! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES call set_args ( '-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T \"my title\" --anytitle:a \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) l = lget ( 'l' ) lupper = lget ( 'L' ) title = sget ( 'title' ) anytitle = sget ( 'anytitle' ) ! With a fixed-size array to ensure the correct number of values are input use call get_args_fixed_size ( 'point' , point ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z , ' point=' , point write ( * , '(*(g0:,1x))' ) 'title=' , trim ( title ), ' l=' , l , 'L=' , lupper write ( * , '(*(g0:,1x))' ) 'anytitle=' , trim ( anytitle ) end program demo1","tags":"","loc":"program/demo1.html"},{"title":"demo_set_mode – M_CLI2","text":"Uses M_CLI2 Contents Variables all Source Code demo_set_mode Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' ! ! enable use of response files call set_mode ( 'response_file' ) ! ! Any dash in a keyname is treated as an underscore call set_mode ( 'underdash' ) ! ! The case of long keynames are ignored. ! Values and short names remain case-sensitive call set_mode ( 'ignorecase' ) ! ! short single-character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keynames. call set_mode ( 'strict' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F' ) ! print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) print all , '--ox or -O ... ' , lget ( 'ox' ) print all , '-o ... ' , lget ( 'o' ) print all , '-x ... ' , lget ( 'x' ) print all , '-t ... ' , lget ( 't' ) end program demo_set_mode","tags":"","loc":"program/demo_set_mode.html"},{"title":"demo_get_subcommand – M_CLI2","text":"Contents Variables l l_ name testname title x y z Subroutines parse Source Code demo_get_subcommand Variables Type Attributes Name Initial logical :: l = .false. logical :: l_ = .false. character(len=20) :: name character(len=80) :: testname = \"not set\" character(len=80) :: title = \"not set\" real :: x = -999.0 real :: y = -999.0 real :: z = -999.0 Subroutines subroutine parse (name) Arguments Type Intent Optional Attributes Name character(len=*) :: name Source Code program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z -title -l -L !x! demo_get_subcommand test -title -l -L -testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x =- 99 9.0 , y =- 99 9.0 , z =- 99 9.0 character ( len = 80 ) :: title = \"not set\" logical :: l = . false . logical :: l_ = . false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) !x! DEFINE AND PARSE COMMAND LINE !x! ALL DONE CRACKING THE COMMAND LINE. !x! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'command was ' , name write ( * , * ) 'x,y,z .... ' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , testname contains subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand","tags":"","loc":"program/demo_get_subcommand.html"},{"title":"demo_get_args – M_CLI2","text":"Uses M_CLI2 Contents Variables i l lbig p title x y z Source Code demo_get_args Variables Type Attributes Name Initial integer :: i logical :: l logical :: lbig real, allocatable :: p (:) character(len=:), allocatable :: title real :: x real :: y real :: z Source Code program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! DEFINE ARGS real :: x , y , z real , allocatable :: p (:) character ( len = :), allocatable :: title logical :: l , lbig ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings and use double-quotes ! o set all logical values to F or T. call set_args ( ' & & -x 1 -y 2 -z 3 & & -p -1,-2,-3 & & --title \"my title\" & & -l F -L F & & --label \" \" & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( 'x' , x , 'y' , y , 'z' , z ) call get_args ( 'l' , l ) call get_args ( 'L' , lbig ) ! ALLOCATABLE STRING call get_args ( 'title' , title ) ! NON-ALLOCATABLE ARRAYS call get_args ( 'p' , p ) ! USE VALUES write ( * , '(1x,g0,\"=\",g0)' ) 'x' , x , 'y' , y , 'z' , z write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig if ( size ( filenames ) > 0 ) then write ( * , '(i6.6,3a)' )( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) endif end program demo_get_args","tags":"","loc":"program/demo_get_args.html"},{"title":"demo_get_args_fixed_length – M_CLI2","text":"Uses M_CLI2 Contents Variables title Source Code demo_get_args_fixed_length Variables Type Attributes Name Initial character(len=80) :: title Source Code program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! DEFINE ARGS character ( len = 80 ) :: title call set_args ( ' & & --title \"my title\" & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_length ( 'title' , title ) ! USE VALUES write ( * , * ) 'title=' , title end program demo_get_args_fixed_length","tags":"","loc":"program/demo_get_args_fixed_length.html"},{"title":"demo_specified – M_CLI2","text":"Uses M_CLI2 Contents Variables flag ints two_names Source Code demo_specified Variables Type Attributes Name Initial integer :: flag integer, allocatable :: ints (:) real, allocatable :: two_names (:) Source Code program demo_specified use M_CLI2 , only : set_args , get_args , specified implicit none ! DEFINE ARGS integer :: flag integer , allocatable :: ints (:) real , allocatable :: two_names (:) ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM call set_args ( '& & --flag 1 -f 1 & & --ints 1,2,3 -i 1,2,3 & & --two_names 11.3 -T 11.3' ) ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME call get_args ( 'flag' , flag ) if ( specified ( 'f' )) call get_args ( 'f' , flag ) call get_args ( 'ints' , ints ) if ( specified ( 'i' )) call get_args ( 'i' , ints ) call get_args ( 'two_names' , two_names ) if ( specified ( 'T' )) call get_args ( 'T' , two_names ) ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE ! ANY(3f) and ALL(3f) write ( * , * ) specified ([ 'two_names' , 'T ' ]) write ( * , * ) 'ANY:' , any ( specified ([ 'two_names' , 'T ' ])) write ( * , * ) 'ALL:' , all ( specified ([ 'two_names' , 'T ' ])) ! FOR MUTUALLY EXCLUSIVE if ( all ( specified ([ 'two_names' , 'T ' ]))) then write ( * , * ) 'You specified both names -T and -two_names' endif ! FOR REQUIRED PARAMETER if (. not . any ( specified ([ 'two_names' , 'T ' ]))) then write ( * , * ) 'You must specify -T or -two_names' endif ! USE VALUES write ( * , * ) 'flag=' , flag write ( * , * ) 'ints=' , ints write ( * , * ) 'two_names=' , two_names end program demo_specified","tags":"","loc":"program/demo_specified.html"},{"title":"demo_get_args_fixed_size – M_CLI2","text":"Uses M_CLI2 Contents Variables cmp dp l lbig p title x y Source Code demo_get_args_fixed_size Variables Type Attributes Name Initial complex :: cmp (2) integer, parameter :: dp = kind(0.0d0) logical :: l (4) logical :: lbig (4) integer :: p (3) character(len=80) :: title (1) real :: x (2) real(kind=dp) :: y (2) Source Code program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0.0d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ), lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings ! o set all logical values to F or T. call set_args ( ' & & -x 10.0,20.0 & & -y 11.0,22.0 & & -p -1,-2,-3 & & --title \"my title\" & & -l F,T,F,T -L T,F,T,F & & --cmp 111,222.0,333.0e0,4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( 'x' , x ) call get_args_fixed_size ( 'y' , y ) call get_args_fixed_size ( 'p' , p ) call get_args_fixed_size ( 'title' , title ) call get_args_fixed_size ( 'l' , l ) call get_args_fixed_size ( 'L' , lbig ) call get_args_fixed_size ( 'cmp' , cmp ) ! USE VALUES write ( * , * ) 'x=' , x write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig write ( * , * ) 'cmp=' , cmp end program demo_get_args_fixed_size","tags":"","loc":"program/demo_get_args_fixed_size.html"},{"title":"M_CLI2.F90 – M_CLI2","text":"Contents Modules M_CLI2 Source Code M_CLI2.F90 Source Code !VERSION 1.0 20200115 !VERSION 2.0 20200802 !VERSION 3.0 20201021 LONG:SHORT syntax !VERSION 3.1 20201115 LONG:SHORT:: syntax !VERSION 3.2 20230203 set_mode() !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument !! parsing using a prototype command !! (LICENSE:PD) !!##SYNOPSIS !! !! Available procedures and variables: !! !! use M_CLI2, only : set_args, get_args, specified, set_mode !! use M_CLI2, only : unnamed, remaining, args !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! !!##DESCRIPTION !! Allow for command line parsing much like standard Unix command line !! parsing using a simple prototype. !! !! Typically one call to SET_ARGS(3f) is made to define the command !! arguments, set default values and parse the command line. Then a call !! is made to the convenience commands based on GET_ARGS(3f) for each !! command keyword to obtain the argument values. !! !! The documentation for SET_ARGS(3f) and GET_ARGS(3f) provides further !! details. !! !!##EXAMPLE !! !! !! Sample typical minimal usage !! !! program minimal !! use M_CLI2, only : set_args, lget, rget, filenames=>unnamed !! implicit none !! real :: x, y !! integer :: i !! call set_args(' -y 0.0 -x 0.0 --debug F') !! x=rget('x') !! y=rget('y') !! if(lget('debug'))then !! write(*,*)'X=',x !! write(*,*)'Y=',y !! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y) !! else !! write(*,*)atan2(x=x,y=y) !! endif !! if(size(filenames) > 0)then !! write(*,'(g0)')'filenames:' !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program minimal !! !! Sample program using get_args() and variants !! !! program demo_M_CLI2 !! use M_CLI2, only : set_args, get_args !! use M_CLI2, only : filenames=>unnamed !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! implicit none !! integer :: i !! integer,parameter :: dp=kind(0.0d0) !! ! !! ! DEFINE ARGS !! real :: x, y, z !! real(kind=dp),allocatable :: point(:) !! logical :: l, lbig !! logical,allocatable :: logicals(:) !! character(len=:),allocatable :: title ! VARIABLE LENGTH !! character(len=40) :: label ! FIXED LENGTH !! real :: p(3) ! FIXED SIZE !! logical :: logi(3) ! FIXED SIZE !! ! !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o set a value for all keywords. !! ! o double-quote strings !! ! o set all logical values to F or T. !! ! o value delimiter is comma, colon, or space !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1 -2 -3 & !! & --point 11.11, 22.22, 33.33e0 & !! & --title \"my title\" -l F -L F & !! & --logicals F F F F F & !! & --logi F T F & !! & --label \" \" & !! ! note space between quotes is required !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args('x',x) ! SCALARS !! call get_args('y',y) !! call get_args('z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! call get_args('title',title) ! ALLOCATABLE STRING !! call get_args('point',point) ! ALLOCATABLE ARRAYS !! call get_args('logicals',logicals) !! ! !! ! for NON-ALLOCATABLE VARIABLES !! !! ! for non-allocatable string !! call get_args_fixed_length('label',label) !! !! ! for non-allocatable arrays !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('logi',logi) !! ! !! ! USE VALUES !! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z !! write(*,*)'p=',p !! write(*,*)'point=',point !! write(*,*)'title=',title !! write(*,*)'label=',label !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'logicals=',logicals !! write(*,*)'logi=',logi !! ! !! ! unnamed strings !! ! !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! ! !! end program demo_M_CLI2 !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== module M_CLI2 use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT , warn => OUTPUT_UNIT ! copied to M_CLI2 for a stand-alone version !use M_strings, only : upper, lower, quote, replace_str=>replace, unquote, split, string_to_value, atleast !use M_list, only : insert, locate, remove, replace !use M_args, only : longest_command_argument !use M_journal, only : journal implicit none integer , parameter , private :: dp = kind ( 0.0d0 ) integer , parameter , private :: sp = kind ( 0.0 ) private !=================================================================================================================================== character ( len =* ), parameter :: gen = '(*(g0))' character ( len = :), allocatable , public :: unnamed (:) character ( len = :), allocatable , public :: args (:) character ( len = :), allocatable , public :: remaining public :: set_mode public :: set_args public :: get_subcommand public :: get_args public :: get_args_fixed_size public :: get_args_fixed_length public :: specified public :: print_dictionary public :: dget , iget , lget , rget , sget , cget public :: dgets , igets , lgets , rgets , sgets , cgets private :: check_commandline private :: wipe_dictionary private :: prototype_to_dictionary private :: update private :: prototype_and_cmd_args_to_nlist private :: get type option character (:), allocatable :: shortname character (:), allocatable :: longname character (:), allocatable :: value integer :: length logical :: present_in logical :: mandatory end type option !=================================================================================================================================== character ( len = :), allocatable , save :: keywords (:) character ( len = :), allocatable , save :: shorts (:) character ( len = :), allocatable , save :: values (:) integer , allocatable , save :: counts (:) logical , allocatable , save :: present_in (:) logical , allocatable , save :: mandatory (:) logical , save :: G_DEBUG = . false . logical , save :: G_UNDERDASH = . false . logical , save :: G_IGNORECASE = . false . logical , save :: G_STRICT = . false . ! strict short and long rules or allow -longname and --shortname logical , save :: G_keyword_single_letter = . true . character ( len = :), allocatable , save :: G_passed_in logical , save :: G_remaining_on , G_remaining_option_allowed character ( len = :), allocatable , save :: G_remaining character ( len = :), allocatable , save :: G_subcommand ! possible candidate for a subcommand character ( len = :), allocatable , save :: G_STOP_MESSAGE integer , save :: G_STOP logical , save :: G_QUIET character ( len = :), allocatable , save :: G_PREFIX !---------------------------------------------- ! try out response files ! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via \"set_mode('response_file') logical , save , public :: CLI_RESPONSE_FILE = . false . ! allow @name abbreviations logical , save :: G_APPEND ! whether to append or replace when duplicate keywords found logical , save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand() logical , save :: G_RESPONSE ! allow @name abbreviations character ( len = :), allocatable , save :: G_RESPONSE_IGNORED !---------------------------------------------- !=================================================================================================================================== ! return allocatable arrays interface get_args ; module procedure get_anyarray_d ; end interface ! any size array interface get_args ; module procedure get_anyarray_i ; end interface ! any size array interface get_args ; module procedure get_anyarray_r ; end interface ! any size array interface get_args ; module procedure get_anyarray_x ; end interface ! any size array interface get_args ; module procedure get_anyarray_c ; end interface ! any size array and any length interface get_args ; module procedure get_anyarray_l ; end interface ! any size array ! return scalars interface get_args ; module procedure get_scalar_d ; end interface interface get_args ; module procedure get_scalar_i ; end interface interface get_args ; module procedure get_scalar_real ; end interface interface get_args ; module procedure get_scalar_complex ; end interface interface get_args ; module procedure get_scalar_logical ; end interface interface get_args ; module procedure get_scalar_anylength_c ; end interface ! any length ! multiple scalars interface get_args ; module procedure many_args ; end interface !================================================================================================================================== ! return non-allocatable arrays ! said in conflict with get_args_*. Using class to get around that. ! that did not work either. Adding size parameter as optional parameter works; but using a different name interface get_args_fixed_size ; module procedure get_fixedarray_class ; end interface ! any length, fixed size array !interface get_args; module procedure get_fixedarray_d; end interface !interface get_args; module procedure get_fixedarray_i; end interface !interface get_args; module procedure get_fixedarray_r; end interface !interface get_args; module procedure get_fixedarray_l; end interface !interface get_args; module procedure get_fixedarray_fixed_length_c; end interface interface get_args_fixed_length ; module procedure get_args_fixed_length_a_array ; end interface ! fixed length any size array interface get_args_fixed_length ; module procedure get_args_fixed_length_scalar_c ; end interface ! fixed length !=================================================================================================================================== !intrinsic findloc !=================================================================================================================================== ! ident_1=\"@(#) M_CLI2 str(3f) {msg_scalar msg_one}\" private str interface str module procedure msg_scalar , msg_one end interface str !=================================================================================================================================== private locate_ ! [M_CLI2] find PLACE in sorted character array where value can be found or should be placed private locate_c private insert_ ! [M_CLI2] insert entry into a sorted allocatable array at specified position private insert_c private insert_i private insert_l private replace_ ! [M_CLI2] replace entry by index from a sorted allocatable array if it is present private replace_c private replace_i private replace_l private remove_ ! [M_CLI2] delete entry by index from a sorted allocatable array if it is present private remove_c private remove_i private remove_l ! Generic subroutine inserts element into allocatable array at specified position interface locate_ ; module procedure locate_c ; end interface interface insert_ ; module procedure insert_c , insert_i , insert_l ; end interface interface replace_ ; module procedure replace_c , replace_i , replace_l ; end interface interface remove_ ; module procedure remove_c , remove_i , remove_l ; end interface !----------------------------------------------------------------------------------------------------------------------------------- ! convenience functions interface cgets ; module procedure cgs , cg ; end interface interface dgets ; module procedure dgs , dg ; end interface interface igets ; module procedure igs , ig ; end interface interface lgets ; module procedure lgs , lg ; end interface interface rgets ; module procedure rgs , rg ; end interface interface sgets ; module procedure sgs , sg ; end interface !----------------------------------------------------------------------------------------------------------------------------------- contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process !! pre-defined options !! !!##SYNOPSIS !! !! subroutine check_commandline(help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! !!##DESCRIPTION !! Checks the commandline and processes the implicit --help, --version, !! --verbose, and --usage parameters. !! !! If the optional text values are supplied they will be displayed by !! --help and --version command-line options, respectively. !! !!##OPTIONS !! !! HELP_TEXT if present, will be displayed if program is called with !! --help switch, and then the program will terminate. If !! not supplied, the command line initialized string will be !! shown when --help is used on the commandline. !! !! VERSION_TEXT if present, will be displayed if program is called with !! --version switch, and then the program will terminate. !! !! If the first four characters of each line are \"@(#)\" this prefix !! will not be displayed and the last non-blank letter will be !! removed from each line. This if for support of the SCCS what(1) !! command. If you do not have the what(1) command on GNU/Linux and !! Unix platforms you can probably see how it can be used to place !! metadata in a binary by entering: !! !! strings demo_commandline|grep '@(#)'|tr '>' '\\n'|sed -e 's/ */ /g' !! !!##EXAMPLE !! !! !! Typical usage: !! !! program check_commandline !! use M_CLI2, only : unnamed, set_args, get_args !! implicit none !! integer :: i !! character(len=:),allocatable :: version_text(:), help_text(:) !! real :: x, y, z !! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' !! version_text=[character(len=80) :: \"version 1.0\",\"author: me\"] !! help_text=[character(len=80) :: & !! & \"wish I put instructions\",\"here\",\"I suppose?\"] !! call set_args(cmd,help_text,version_text) !! call get_args('x',x,'y',y,'z',z) !! ! All done cracking the command line. Use the values in your program. !! write (*,*)x,y,z !! ! the optional unnamed values on the command line are !! ! accumulated in the character array \"UNNAMED\" !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program check_commandline !=================================================================================================================================== subroutine check_commandline ( help_text , version_text ) character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len = :), allocatable :: line integer :: i integer :: istart integer :: iback if ( get ( 'usage' ) == 'T' ) then call print_dictionary ( 'USAGE:' ) !x!call default_help() call mystop ( 32 ) return endif if ( present ( help_text )) then if ( get ( 'help' ) == 'T' ) then do i = 1 , size ( help_text ) call journal ( 'sc' , help_text ( i )) enddo call mystop ( 1 , 'displayed help text' ) return endif elseif ( get ( 'help' ) == 'T' ) then call default_help () call mystop ( 2 , 'displayed default help text' ) return endif if ( present ( version_text )) then if ( get ( 'version' ) == 'T' ) then istart = 1 iback = 0 if ( size ( version_text ) > 0 ) then if ( index ( version_text ( 1 ), '@' // '(#)' ) == 1 ) then ! allow for what(1) syntax istart = 5 iback = 1 endif endif do i = 1 , size ( version_text ) !xINTEL BUG*!call journal('sc',version_text(i)(istart:len_trim(version_text(i))-iback)) line = version_text ( i )( istart : len_trim ( version_text ( i )) - iback ) call journal ( 'sc' , line ) enddo call mystop ( 3 , 'displayed version text' ) return endif elseif ( get ( 'version' ) == 'T' ) then if ( G_QUIET ) then G_STOP_MESSAGE = 'no version text' else call journal ( 'sc' , '*check_commandline* no version text' ) endif call mystop ( 4 , 'displayed default version text' ) return endif contains subroutine default_help () character ( len = :), allocatable :: cmd_name integer :: ilength call get_command_argument ( number = 0 , length = ilength ) if ( allocated ( cmd_name )) deallocate ( cmd_name ) allocate ( character ( len = ilength ) :: cmd_name ) call get_command_argument ( number = 0 , value = cmd_name ) G_passed_in = G_passed_in // repeat ( ' ' , len ( G_passed_in )) call substitute ( G_passed_in , ' --' , NEW_LINE ( 'A' ) // ' --' ) if (. not . G_QUIET ) then call journal ( 'sc' , cmd_name , G_passed_in ) ! no help text, echo command and default options endif deallocate ( cmd_name ) end subroutine default_help end subroutine check_commandline !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_args(definition,help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: definition !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! integer,intent(out),optional :: ierr !! character(len=:),intent(out),allocatable,optional :: errmsg !!##DESCRIPTION !! !! SET_ARGS(3f) requires a unix-like command prototype for defining !! arguments and default command-line options. Argument values are then !! read using GET_ARGS(3f). !! !! The --help and --version options require the optional !! help_text and version_text values to be provided. !! !!##OPTIONS !! !! DEFINITION composed of all command arguments concatenated !! into a Unix-like command prototype string. For !! example: !! !! call set_args('-L F --ints 1,2,3 --title \"my title\" -R 10.3') !! !! DEFINITION is pre-defined to act as if started with !! the reserved options '--verbose F --usage F --help !! F --version F'. The --usage option is processed when !! the set_args(3f) routine is called. The same is true !! for --help and --version if the optional help_text !! and version_text options are provided. !! !! see \"DEFINING THE PROTOTYPE\" in the next section for !! further details. !! !! HELP_TEXT if present, will be displayed if program is called with !! --help switch, and then the program will terminate. If !! not supplied, the command line initialization string !! will be shown when --help is used on the commandline. !! !! VERSION_TEXT if present, will be displayed if program is called with !! --version switch, and then the program will terminate. !! IERR if present a non-zero option is returned when an !! error occurs instead of program execution being !! terminated !! ERRMSG a description of the error if ierr is present !! !!##DEFINING THE PROTOTYPE !! !! o all keywords on the prototype MUST get a value. !! !! + logicals must be set to F or T. !! !! + strings must be delimited with double-quotes and !! must be at least one space. Internal double-quotes !! are represented with two double-quotes. !! !! o numeric keywords are not allowed; but this allows !! negative numbers to be used as values. !! !! o lists of values should be comma-delimited unless a !! user-specified delimiter is used. The prototype !! must use the same array delimiters as the call to !! get the value. !! !! o to define a zero-length allocatable array make the !! value a delimiter (usually a comma). !! !! o all unused values go into the character array UNNAMED !! !! LONG AND SHORT NAMES !! !! o It is recommended long names (--keyword) should be all lowercase !! but are case-sensitive by default, unless set_mode('ignorecase') !! is in effect. !! !! o Long names should always be more than one character. !! !! o The recommended way to have short names is to suffix the long !! name with :LETTER in the definition. If this syntax is used !! then logical shorts may be combined on the command line. !! !! Mapping of short names to long names __not__ using the !! --LONGNAME:SHORTNAME syntax is demonstrated in the manpage !! for SPECIFIED(3f). !! !! SPECIAL BEHAVIORS !! !! o A very special behavior occurs if the keyword name ends in ::. !! When the program is called the next parameter is taken as !! a value even if it starts with -. This is not generally !! recommended but is useful in rare cases where non-numeric !! values starting with a dash are desired. !! !! o If the prototype ends with \"--\" a special mode is turned !! on where anything after \"--\" on input goes into the variable !! REMAINING and the array ARGS instead of becoming elements in !! the UNNAMED array. This is not needed for normal processing. !! !!##USAGE !! When invoking the program line note that (subject to change) the !! following variations from other common command-line parsers: !! !! o values for duplicate keywords are appended together with a space !! separator when a command line is executed. !! !! o Although not generally recommended you can equivalence !! keywords (usually for multi-lingual support). Be aware that !! specifying both names of an equivalenced keyword on a command !! line will have undefined results (currently, their ASCII !! alphabetical order will define what the Fortran variable !! values become). !! !! The second of the names should only be queried if the !! SPECIFIED(3f) function is .TRUE. for that name. !! !! Note that allocatable arrays cannot be EQUIVALENCEd in Fortran. !! !! o short Boolean keywords cannot be combined reliably unless !! \"set_mode('strict')\" is in effect. Short names that require !! a value cannot be bundled together. Non-Boolean key names may !! not be bundled. !! !! o shuffling is not supported. Values immediately follow their !! keywords. !! !! o if a parameter value of just \"-\" is supplied it is !! converted to the string \"stdin\". !! !! o values not matching a keyword go into the character !! array \"UNUSED\". !! !! o if the keyword \"--\" is encountered on the command line the !! rest of the command arguments go into the character array !! \"UNUSED\". !!##EXAMPLE !! !! !! Sample program: !! !! program demo_set_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! use M_CLI2, only : get_args_fixed_size !! implicit none !! integer :: i !! ! DEFINE ARGS !! real :: x, y, z !! real :: p(3) !! character(len=:),allocatable :: title !! logical :: l, lbig !! integer,allocatable :: ints(:) !! ! !! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) !! ! AND READ COMMAND LINE !! call set_args(' & !! ! reals !! & -x 1 -y 2.3 -z 3.4e2 & !! ! integer array !! & -p -1,-2,-3 & !! ! always double-quote strings !! & --title \"my title\" & !! ! string should be a single character at a minimum !! & --label \" \", & !! ! set all logical values to F or T. !! & -l F -L F & !! ! set allocatable size to zero if you like by using a delimiter !! & --ints , & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! ! SCALARS !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! call get_args('ints',ints) ! ALLOCATABLE ARRAY !! call get_args('title',title) ! ALLOCATABLE STRING !! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'y=',y !! write(*,*)'z=',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'ints=',ints !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! ! UNNAMED VALUES !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_set_args !! !!##RESPONSE FILES !! !! If you have no interest in using external files as abbreviations !! you can ignore this section. Otherwise, before calling set_args(3f) !! add: !! !! use M_CLI2, only : set_mode !! call set_mode('response_file') !! !! M_CLI2 Response files are small files containing CLI (Command Line !! Interface) arguments that end with \".rsp\" that can be used when command !! lines are so long that they would exceed line length limits or so complex !! that it is useful to have a platform-independent method of creating !! an abbreviation. !! !! Shell aliases and scripts are often used for similar purposes (and !! allow for much more complex conditional execution, of course), but !! they generally cannot be used to overcome line length limits and are !! typically platform-specific. !! !! Examples of commands that support similar response files are the Clang !! and Intel compilers, although there is no standard format for the files. !! !! They are read if you add options of the syntax \"@NAME\" as the FIRST !! parameters on your program command line calls. They are not recursive -- !! that is, an option in a response file cannot be given the value \"@NAME2\" !! to call another response file. !! !! More than one response name may appear on a command line. !! !! They are case-sensitive names. !! !! Note \"@\" s a special character in Powershell, and requires being escaped !! with a grave character. !! !! LOCATING RESPONSE FILES !! !! A search for the response file always starts with the current directory. !! The search then proceeds to look in any additional directories specified !! with the colon-delimited environment variable CLI_RESPONSE_PATH. !! !! The first resource file found that results in lines being processed !! will be used and processing stops after that first match is found. If !! no match is found an error occurs and the program is stopped. !! !! RESPONSE FILE SECTIONS !! !! A simple response file just has options for calling the program in it !! prefixed with the word \"options\". !! But they can also contain section headers to denote selections that are !! only executed when a specific OS is being used, print messages, and !! execute system commands. !! !! SEARCHING FOR OSTYPE IN REGULAR FILES !! !! So assuming the name @NAME was specified on the command line a file !! named NAME.rsp will be searched for in all the search directories !! and then in that file a string that starts with the string @OSTYPE !! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE !! takes precedence over $OS). !! !! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES !! !! Then, the same files will be searched for lines above any line starting !! with \"@\". That is, if there is no special section for the current OS !! it just looks at the top of the file for unlabeled options. !! !! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE !! !! In addition or instead of files with the same name as the @NAME option !! on the command line, you can have one file named after the executable !! name that contains multiple abbreviation names. !! !! So if your program executable is named EXEC you create a single file !! called EXEC.rsp and can append all the simple files described above !! separating them with lines of the form @OSTYPE@NAME or just @NAME. !! !! So if no specific file for the abbreviation is found a file called !! \"EXEC.rsp\" is searched for where \"EXEC\" is the name of the executable. !! This file is always a \"compound\" response file that uses the following format: !! !! Any compound EXEC.rsp file found in the current or searched directories !! will be searched for the string @OSTYPE@NAME first. !! !! Then if nothing is found, the less specific line @NAME is searched for. !! !! THE SEARCH IS OVER !! !! Sounds complicated but actually works quite intuitively. Make a file in !! the current directory and put options in it and it will be used. If that !! file ends up needing different cases for different platforms add a line !! like \"@Linux\" to the file and some more lines and that will only be !! executed if the environment variable OSTYPE or OS is \"Linux\". If no match !! is found for named sections the lines at the top before any \"@\" lines !! will be used as a default if no match is found. !! !! If you end up using a lot of files like this you can combine them all !! together and put them into a file called \"program_name\".rsp and just !! put lines like @NAME or @OSTYPE@NAME at that top of each selection. !! !! Now, back to the details on just what you can put in the files. !! !!##SPECIFICATION FOR RESPONSE FILES !! !! SIMPLE RESPONSE FILES !! !! The first word of a line is special and has the following meanings: !! !! options|- Command options following the rules of the SET_ARGS(3f) !! prototype. So !! o It is preferred to specify a value for all options. !! o double-quote strings. !! o give a blank string value as \" \". !! o use F|T for lists of logicals, !! o lists of numbers should be comma-delimited. !! o --usage, --help, --version, --verbose, and unknown !! options are ignored. !! !! comment|# Line is a comment line !! system|! System command. !! System commands are executed as a simple call to !! system (so a cd(1) or setting a shell variable !! would not effect subsequent lines, for example) !! BEFORE the command being processed. !! print|> Message to screen !! stop display message and stop program. !! !! NOTE: system commands are executed when encountered, but options are !! gathered from multiple option lines and passed together at the end of !! processing of the block; so all commands will be executed BEFORE the !! command for which options are being supplied no matter where they occur. !! !! So if a program that does nothing but echos its parameters !! !! program testit !! use M_CLI2, only : set_args, rget, sget, lget, set_mode !! implicit none !! real :: x,y ; namelist/args/ x,y !! character(len=:),allocatable :: title ; namelist/args/ title !! logical :: big ; namelist/args/ big !! call set_mode('response_file') !! call set_args('-x 10.0 -y 20.0 --title \"my title\" --big F') !! x=rget('x') !! y=rget('y') !! title=sget('title') !! big=lget('big') !! write(*,nml=args) !! end program testit !! !! And a file in the current directory called \"a.rsp\" contains !! !! # defaults for project A !! options -x 1000 -y 9999 !! options --title \" \" !! options --big T !! !! The program could be called with !! !! $myprog # normal call !! X=10.0 Y=20.0 TITLE=\"my title\" !! !! $myprog @a # change defaults as specified in \"a.rsp\" !! X=1000.0 Y=9999.0 TITLE=\" \" !! !! # change defaults but use any option as normal to override defaults !! $myprog @a -y 1234 !! X=1000.0 Y=1234.0 TITLE=\" \" !! !! COMPOUND RESPONSE FILES !! !! A compound response file has the same basename as the executable with a !! \".rsp\" suffix added. So if your program is named \"myprg\" the filename !! must be \"myprg.rsp\". !! !! Note that here `basename` means the last leaf of the !! name of the program as returned by the Fortran intrinsic !! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period (\".\"), !! so it is a good idea not to use hidden files. !! !! Unlike simple response files compound response files can contain multiple !! setting names. !! !! Specifically in a compound file !! if the environment variable $OSTYPE (first) or $OS is set the first search !! will be for a line of the form (no leading spaces should be used): !! !! @OSTYPE@alias_name !! !! If no match or if the environment variables $OSTYPE and $OS were not !! set or a match is not found then a line of the form !! !! @alias_name !! !! is searched for in simple or compound files. If found subsequent lines !! will be ignored that start with \"@\" until a line not starting with !! \"@\" is encountered. Lines will then be processed until another line !! starting with \"@\" is found or end-of-file is encountered. !! !! COMPOUND RESPONSE FILE EXAMPLE !! An example compound file !! !! ################# !! @if !! > RUNNING TESTS USING RELEASE VERSION AND ifort !! options test --release --compiler ifort !! ################# !! @gf !! > RUNNING TESTS USING RELEASE VERSION AND gfortran !! options test --release --compiler gfortran !! ################# !! @nv !! > RUNNING TESTS USING RELEASE VERSION AND nvfortran !! options test --release --compiler nvfortran !! ################# !! @nag !! > RUNNING TESTS USING RELEASE VERSION AND nagfor !! options test --release --compiler nagfor !! # !! ################# !! # OS-specific example: !! @Linux@install !! # !! # install executables in directory (assuming install(1) exists) !! # !! system mkdir -p ~/.local/bin !! options run --release T --runner \"install -vbp -m 0711 -t ~/.local/bin\" !! @install !! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET !! # !! ################# !! @fpm@testall !! # !! !fpm test --compiler nvfortran !! !fpm test --compiler ifort !! !fpm test --compiler gfortran !! !fpm test --compiler nagfor !! STOP tests complete. Any additional parameters were ignored !! ################# !! !! Would be used like !! !! fpm @install !! fpm @nag -- !! fpm @testall !! !! NOTES !! !! The intel Fortran compiler now calls the response files \"indirect !! files\" and does not add the implied suffix \".rsp\" to the files !! anymore. It also allows the @NAME syntax anywhere on the command line, !! not just at the beginning. -- 20201212 !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine set_args ( prototype , help_text , version_text , string , prefix , ierr , errmsg ) ! ident_2=\"@(#) M_CLI2 set_args(3f) parse prototype string\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len =* ), intent ( in ), optional :: string character ( len =* ), intent ( in ), optional :: prefix integer , intent ( out ), optional :: ierr character ( len = :), intent ( out ), allocatable , optional :: errmsg character ( len = :), allocatable :: hold ! stores command line argument integer :: ibig character ( len = :), allocatable :: debug_mode debug_mode = upper ( get_env ( 'CLI_DEBUG_MODE' , 'FALSE' )) // ' ' select case ( debug_mode ( 1 : 1 )) case ( 'Y' , 'T' ) G_DEBUG = . true . end select G_response = CLI_RESPONSE_FILE G_options_only = . false . G_append = . true . G_passed_in = '' G_STOP = 0 G_STOP_MESSAGE = '' if ( present ( prefix )) then G_PREFIX = prefix else G_PREFIX = '' endif if ( present ( ierr )) then G_QUIET = . true . else G_QUIET = . false . endif ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) call wipe_dictionary () hold = '--version F --usage F --help F --version F ' // adjustl ( prototype ) call prototype_and_cmd_args_to_nlist ( hold , string ) if ( allocated ( G_RESPONSE_IGNORED )) then if ( G_DEBUG ) write ( * , gen ) 'SET_ARGS:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED if ( size ( unnamed ) /= 0 ) write ( * , * ) 'LOGIC ERROR' call split ( G_RESPONSE_IGNORED , unnamed ) endif if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif if (. not . allocated ( args )) then allocate ( character ( len = 0 ) :: args ( 0 )) endif call check_commandline ( help_text , version_text ) ! process --help, --version, --usage if ( present ( ierr )) then ierr = G_STOP endif if ( present ( errmsg )) then errmsg = G_STOP_MESSAGE endif end subroutine set_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for !! handling subcommands on a command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function get_subcommand() !! !! character(len=:),allocatable :: get_subcommand !! !!##DESCRIPTION !! In the special case when creating a program with subcommands it !! is assumed the first word on the command line is the subcommand. A !! routine is required to handle response file processing, therefore !! this routine (optionally processing response files) returns that !! first word as the subcommand name. !! !! It should not be used by programs not building a more elaborate !! command with subcommands. !! !!##RETURNS !! NAME name of subcommand !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_subcommand !! !x! SUBCOMMANDS !! !x! For a command with subcommands like git(1) !! !x! you can make separate namelists for each subcommand. !! !x! You can call this program which has two subcommands (run, test), !! !x! like this: !! !x! demo_get_subcommand --help !! !x! demo_get_subcommand run -x -y -z -title -l -L !! !x! demo_get_subcommand test -title -l -L -testname !! !x! demo_get_subcommand run --help !! implicit none !! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES !! real :: x=-999.0,y=-999.0,z=-999.0 !! character(len=80) :: title=\"not set\" !! logical :: l=.false. !! logical :: l_=.false. !! character(len=80) :: testname=\"not set\" !! character(len=20) :: name !! call parse(name) !x! DEFINE AND PARSE COMMAND LINE !! !x! ALL DONE CRACKING THE COMMAND LINE. !! !x! USE THE VALUES IN YOUR PROGRAM. !! write(*,*)'command was ',name !! write(*,*)'x,y,z .... ',x,y,z !! write(*,*)'title .... ',title !! write(*,*)'l,l_ ..... ',l,l_ !! write(*,*)'testname . ',testname !! contains !! subroutine parse(name) !! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY !! use M_CLI2, only : set_args, get_args, get_args_fixed_length !! use M_CLI2, only : get_subcommand, set_mode !! character(len=*) :: name ! the subcommand name !! character(len=:),allocatable :: help_text(:), version_text(:) !! call set_mode('response_file') !! ! define version text !! version_text=[character(len=80) :: & !! '@(#)PROGRAM: demo_get_subcommand >', & !! '@(#)DESCRIPTION: My demo program >', & !! '@(#)VERSION: 1.0 20200715 >', & !! '@(#)AUTHOR: me, myself, and I>', & !! '@(#)LICENSE: Public Domain >', & !! '' ] !! ! general help for \"demo_get_subcommand --help\" !! help_text=[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L -title -x -y -z ', & !! ' * test -l -L -title ', & !! '' ] !! ! find the subcommand name by looking for first word on command !! ! not starting with dash !! name = get_subcommand() !! select case(name) !! case('run') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand \"run\" ', & !! ' ', & !! '' ] !! call set_args( & !! & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F',& !! & help_text,version_text) !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! case('test') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand \"test\" ', & !! ' ', & !! '' ] !! call set_args(& !! & '--title \"my title\" -l F -L F --testname \"Test\"',& !! & help_text,version_text) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! call get_args_fixed_length('testname',testname) !! case default !! ! process help and version !! call set_args(' ',help_text,version_text) !! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']' !! write(*,'(a)')[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L -title -x -y -z ', & !! ' * test -l -L -title ', & !! '' ] !! stop !! end select !! end subroutine parse !! end program demo_get_subcommand !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== function get_subcommand () result ( sub ) ! ident_3=\"@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files\" character ( len = :), allocatable :: sub character ( len = :), allocatable :: cmdarg character ( len = :), allocatable :: array (:) character ( len = :), allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand = '' G_options_only = . true . sub = '' if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif ilongest = longest_command_argument () allocate ( character ( len = max ( 63 , ilongest )) :: cmdarg ) cmdarg (:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( scan ( adjustl ( cmdarg ( 1 : 1 )), '@' ) == 1 ) then call get_prototype ( cmdarg , prototype ) call split ( prototype , array ) ! assume that if using subcommands first word not starting with dash is the subcommand do j = 1 , size ( array ) if ( adjustl ( array ( j )( 1 : 1 )) /= '-' ) then G_subcommand = trim ( array ( j )) sub = G_subcommand exit endif enddo endif enddo if ( G_subcommand /= '' ) then sub = G_subcommand elseif ( size ( unnamed ) /= 0 ) then sub = unnamed ( 1 ) else cmdarg (:) = '' do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( adjustl ( cmdarg ( 1 : 1 )) /= '-' ) then sub = trim ( cmdarg ) exit endif enddo endif G_options_only = . false . end function get_subcommand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !=================================================================================================================================== subroutine set_usage ( keyword , description , value ) character ( len =* ), intent ( in ) :: keyword character ( len =* ), intent ( in ) :: description character ( len =* ), intent ( in ) :: value write ( * , * ) keyword write ( * , * ) description write ( * , * ) value ! store the descriptions in an array and then apply them when set_args(3f) is called. ! alternatively, could allow for a value as well in lieu of the prototype end subroutine set_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command !! and store tokens into dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! recursive subroutine prototype_to_dictionary(string) !! !! character(len=*),intent(in) :: string !! !!##DESCRIPTION !! given a string of form !! !! -var value -var value !! !! define dictionary of form !! !! keyword(i), value(i) !! !! o string values !! !! o must be delimited with double quotes. !! o adjacent double quotes put one double quote into value !! o must not be null. A blank is specified as \" \", not \"\". !! !! o logical values !! !! o logical values must have a value !! !! o leading and trailing blanks are removed from unquoted values !! !! !!##OPTIONS !! STRING string is character input string to define command !! !!##RETURNS !! !!##EXAMPLE !! !! sample program: !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== recursive subroutine prototype_to_dictionary ( string ) ! ident_4=\"@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary\" character ( len =* ), intent ( in ) :: string ! string is character input string of options and values character ( len = :), allocatable :: dummy ! working copy of string character ( len = :), allocatable :: value character ( len = :), allocatable :: keyword character ( len = 3 ) :: delmt ! flag if in a delimited string or not character ( len = 1 ) :: currnt ! current character being processed character ( len = 1 ) :: prev ! character to left of CURRNT character ( len = 1 ) :: forwrd ! character to right of CURRNT integer , dimension ( 2 ) :: ipnt integer :: islen ! number of characters in input string integer :: ipoint integer :: itype integer , parameter :: VAL = 1 , KEYW = 2 integer :: ifwd integer :: ibegin integer :: iend integer :: place islen = len_trim ( string ) ! find number of characters in input string if ( islen == 0 ) then ! if input string is blank, even default variable will not be changed return endif dummy = adjustl ( string ) // ' ' keyword = \"\" ! initial variable name value = \"\" ! initial value of a string ipoint = 0 ! ipoint is the current character pointer for (dummy) ipnt ( 2 ) = 2 ! pointer to position in keyword ipnt ( 1 ) = 1 ! pointer to position in value itype = VAL ! itype=1 for value, itype=2 for variable delmt = \"off\" prev = \" \" G_keyword_single_letter = . true . do ipoint = ipoint + 1 ! move current character pointer forward currnt = dummy ( ipoint : ipoint ) ! store current character into currnt ifwd = min ( ipoint + 1 , islen ) ! ensure not past end of string forwrd = dummy ( ifwd : ifwd ) ! next character (or duplicate if last) if (( currnt == \"-\" . and . prev == \" \" . and . delmt == \"off\" . and . index ( \"0123456789.\" , forwrd ) == 0 ). or . ipoint > islen ) then ! beginning of a keyword if ( forwrd == '-' ) then ! change --var to -var so \"long\" syntax is supported !x!dummy(ifwd:ifwd)='_' ipoint = ipoint + 1 ! ignore second - instead (was changing it to _) G_keyword_single_letter = . false . ! flag this is a long keyword else G_keyword_single_letter = . true . ! flag this is a short (single letter) keyword endif if ( ipnt ( 1 ) - 1 >= 1 ) then ! position in value ibegin = 1 iend = len_trim ( value (: ipnt ( 1 ) - 1 )) TESTIT : do if ( iend == 0 ) then ! len_trim returned 0, value is blank iend = ibegin exit TESTIT elseif ( value ( ibegin : ibegin ) == \" \" ) then ibegin = ibegin + 1 else exit TESTIT endif enddo TESTIT if ( keyword /= ' ' ) then call update ( keyword , value ) ! store name and its value elseif ( G_remaining_option_allowed ) then ! meaning \"--\" has been encountered call update ( '_args_' , trim ( value )) else !x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword) G_RESPONSE_IGNORED = TRIM ( VALUE ) if ( G_DEBUG ) write ( * , gen ) 'PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED endif else call locate_key ( keyword , place ) if ( keyword /= ' ' . and . place < 0 ) then call update ( keyword , 'F' ) ! store name and null value (first pass) elseif ( keyword /= ' ' ) then call update ( keyword , ' ' ) ! store name and null value (second pass) elseif (. not . G_keyword_single_letter . and . ipoint - 2 == islen ) then ! -- at end of line G_remaining_option_allowed = . true . ! meaning for \"--\" is that everything on commandline goes into G_remaining endif endif itype = KEYW ! change to expecting a keyword value = \"\" ! clear value for this variable keyword = \"\" ! clear variable name ipnt ( 1 ) = 1 ! restart variable value ipnt ( 2 ) = 1 ! restart variable name else ! currnt is not one of the special characters ! the space after a keyword before the value if ( currnt == \" \" . and . itype == KEYW ) then ! switch from building a keyword string to building a value string itype = VAL ! beginning of a delimited value elseif ( currnt == \"\"\"\" . and . itype == VAL ) then ! second of a double quote, put quote in if ( prev == \"\"\"\" ) then if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 delmt = \"on\" elseif ( delmt == \"on\" ) then ! first quote of a delimited string delmt = \"off\" else delmt = \"on\" endif if ( prev /= \"\"\"\" ) then ! leave quotes where found them if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 endif else ! add character to current keyword or value if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 endif endif prev = currnt if ( ipoint <= islen ) then cycle else exit endif enddo end subroutine prototype_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present !! on command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental impure function specified(name) !! !! character(len=*),intent(in) :: name !! logical :: specified !! !!##DESCRIPTION !! !! specified(3f) returns .true. if the specified keyword was present on !! the command line. !! !!##OPTIONS !! !! NAME name of commandline argument to query the presence of !! !!##RETURNS !! SPECIFIED returns .TRUE. if specified NAME was present on the command !! line when the program was invoked. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_specified !! use M_CLI2, only : set_args, get_args, specified !! implicit none !! ! DEFINE ARGS !! integer :: flag !! integer,allocatable :: ints(:) !! real,allocatable :: two_names(:) !! !! ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED !! ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM !! call set_args('& !! & --flag 1 -f 1 & !! & --ints 1,2,3 -i 1,2,3 & !! & --two_names 11.3 -T 11.3') !! !! ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME !! call get_args('flag',flag) !! if(specified('f'))call get_args('f',flag) !! call get_args('ints',ints) !! if(specified('i'))call get_args('i',ints) !! call get_args('two_names',two_names) !! if(specified('T'))call get_args('T',two_names) !! !! ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE !! ! ANY(3f) and ALL(3f) !! write(*,*)specified(['two_names','T ']) !! write(*,*)'ANY:',any(specified(['two_names','T '])) !! write(*,*)'ALL:',all(specified(['two_names','T '])) !! !! ! FOR MUTUALLY EXCLUSIVE !! if (all(specified(['two_names','T '])))then !! write(*,*)'You specified both names -T and -two_names' !! endif !! !! ! FOR REQUIRED PARAMETER !! if (.not.any(specified(['two_names','T '])))then !! write(*,*)'You must specify -T or -two_names' !! endif !! ! USE VALUES !! write(*,*)'flag=',flag !! write(*,*)'ints=',ints !! write(*,*)'two_names=',two_names !! end program demo_specified !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure function specified ( key ) character ( len =* ), intent ( in ) :: key logical :: specified integer :: place call locate_key ( key , place ) ! find where string is or should be if ( place < 1 ) then specified = . false . else specified = present_in ( place ) endif end function specified !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given !! keyword and value !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine update(key,val) !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: val !!##DESCRIPTION !! Update internal dictionary in M_CLI2(3fm) module. !!##OPTIONS !! key name of keyword to add, replace, or delete from dictionary !! val if present add or replace value associated with keyword. If not !! present remove keyword entry from dictionary. !! !! If \"present\" is true, a value will be appended !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine update ( key , val ) character ( len =* ), intent ( in ) :: key character ( len =* ), intent ( in ), optional :: val integer :: place , ii integer :: iilen character ( len = :), allocatable :: val_local character ( len = :), allocatable :: short character ( len = :), allocatable :: long character ( len = :), allocatable :: long_short (:) integer :: isize logical :: set_mandatory set_mandatory = . false . call split ( trim ( key ), long_short , ':' , nulls = 'return' ) ! split long:short keyname or long:short:: or long:: or short:: ! check for :: on end isize = size ( long_short ) if ( isize > 0 ) then ! very special-purpose syntax where if ends in :: next field is a value even if ( long_short ( isize ) == '' ) then ! if it starts with a dash, for --flags option on fpm(1). set_mandatory = . true . long_short = long_short (: isize - 1 ) endif endif select case ( size ( long_short )) case ( 0 ) long = '' short = '' case ( 1 ) long = trim ( long_short ( 1 )) if ( len_trim ( long ) == 1 ) then !x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value ii = maxloc ([ 0 , merge ( 1 , 0 , shorts == long )], dim = 1 ) if ( ii > 1 ) then long = keywords ( ii - 1 ) endif short = long else short = '' endif case ( 2 ) long = trim ( long_short ( 1 )) short = trim ( long_short ( 2 )) case default write ( warn , * ) 'WARNING: incorrect syntax for key: ' , trim ( key ) long = trim ( long_short ( 1 )) short = trim ( long_short ( 2 )) end select if ( G_UNDERDASH ) then long = replace_str ( long , '-' , '_' ) endif if ( G_IGNORECASE . and . len ( long ) > 1 ) long = lower ( long ) if ( present ( val )) then val_local = val iilen = len_trim ( val_local ) call locate_key ( long , place ) ! find where string is or should be if ( place < 1 ) then ! if string was not found insert it call insert_ ( keywords , long , iabs ( place )) call insert_ ( values , val_local , iabs ( place )) call insert_ ( counts , iilen , iabs ( place )) call insert_ ( shorts , short , iabs ( place )) call insert_ ( present_in ,. true ., iabs ( place )) call insert_ ( mandatory , set_mandatory , iabs ( place )) else if ( present_in ( place )) then ! if multiple keywords append values with space between them if ( G_append ) then if ( values ( place )( 1 : 1 ) == '\"' ) then ! UNDESIRABLE: will ignore previous blank entries val_local = '\"' // trim ( unquote ( values ( place ))) // ' ' // trim ( unquote ( val_local )) // '\"' else val_local = values ( place ) // ' ' // val_local endif endif iilen = len_trim ( val_local ) endif call replace_ ( values , val_local , place ) call replace_ ( counts , iilen , place ) call replace_ ( present_in ,. true ., place ) endif else ! if no value is present remove the keyword and related values call locate_key ( long , place ) ! check name as long and short if ( place > 0 ) then call remove_ ( keywords , place ) call remove_ ( values , place ) call remove_ ( counts , place ) call remove_ ( shorts , place ) call remove_ ( present_in , place ) call remove_ ( mandatory , place ) endif endif end subroutine update !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm) !! dictionary to empty !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine wipe_dictionary() !!##DESCRIPTION !! reset private M_CLI2(3fm) dictionary to empty !!##EXAMPLE !! !! Sample program: !! !! program demo_wipe_dictionary !! use M_CLI2, only : dictionary !! call wipe_dictionary() !! end program demo_wipe_dictionary !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine wipe_dictionary () if ( allocated ( keywords )) deallocate ( keywords ) allocate ( character ( len = 0 ) :: keywords ( 0 )) if ( allocated ( values )) deallocate ( values ) allocate ( character ( len = 0 ) :: values ( 0 )) if ( allocated ( counts )) deallocate ( counts ) allocate ( counts ( 0 )) if ( allocated ( shorts )) deallocate ( shorts ) allocate ( character ( len = 0 ) :: shorts ( 0 )) if ( allocated ( present_in )) deallocate ( present_in ) allocate ( present_in ( 0 )) if ( allocated ( mandatory )) deallocate ( mandatory ) allocate ( mandatory ( 0 )) end subroutine wipe_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with !! key name in private M_CLI2(3fm) dictionary !!##SYNOPSIS !! !! !!##DESCRIPTION !! Get dictionary value associated with key name in private M_CLI2(3fm) !! dictionary. !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !=================================================================================================================================== function get ( key ) result ( valout ) character ( len =* ), intent ( in ) :: key character ( len = :), allocatable :: valout integer :: place ! find where string is or should be call locate_key ( key , place ) if ( place < 1 ) then valout = '' else valout = values ( place )(: counts ( place )) endif end function get !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert !! Unix-like command arguments to table !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine prototype_and_cmd_args_to_nlist(prototype) !! !! character(len=*) :: prototype !!##DESCRIPTION !! create dictionary with character keywords, values, and value lengths !! using the routines for maintaining a list from command line arguments. !!##OPTIONS !! prototype !!##EXAMPLE !! !! Sample program !! !! program demo_prototype_and_cmd_args_to_nlist !! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed !! implicit none !! character(len=:),allocatable :: readme !! character(len=256) :: message !! integer :: ios !! integer :: i !! doubleprecision :: something !! !! ! define arguments !! logical :: l,h,v !! real :: p(2) !! complex :: c !! doubleprecision :: x,y,z !! !! ! uppercase keywords get an underscore to make it easier o remember !! logical :: l_,h_,v_ !! ! character variables must be long enough to hold returned value !! character(len=256) :: a_,b_ !! integer :: c_(3) !! !! ! give command template with default values !! ! all values except logicals get a value. !! ! strings must be delimited with double quotes !! ! A string has to have at least one character as for -A !! ! lists of numbers should be comma-delimited. !! ! No spaces are allowed in lists of numbers !! call prototype_and_cmd_args_to_nlist('& !! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & !! & -A \" \" -B \"Value B\" -C 10,20,30 -c (-123,-456)',readme) !! !! call get_args('x',x,'y',y,'z',z) !! something=sqrt(x**2+y**2+z**2) !! write (*,*)something,x,y,z !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program demo_prototype_and_cmd_args_to_nlist !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine prototype_and_cmd_args_to_nlist ( prototype , string ) ! ident_5=\"@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: string integer :: ibig integer :: itrim integer :: iused if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:START' G_passed_in = prototype ! make global copy for printing ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine ibig = max ( ibig , 1 ) IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) G_remaining_option_allowed = . false . G_remaining_on = . false . G_remaining = '' if ( prototype /= '' ) then call prototype_to_dictionary ( prototype ) ! build dictionary from prototype ! if short keywords not used by user allow them for standard options call locate_key ( 'h' , iused ) if ( iused <= 0 ) then call update ( 'help' ) call update ( 'help:h' , 'F' ) endif call locate_key ( 'v' , iused ) if ( iused <= 0 ) then call update ( 'version' ) call update ( 'version:v' , 'F' ) endif call locate_key ( 'V' , iused ) if ( iused <= 0 ) then call update ( 'verbose' ) call update ( 'verbose:V' , 'F' ) endif call locate_key ( 'u' , iused ) if ( iused <= 0 ) then call update ( 'usage' ) call update ( 'usage:u' , 'F' ) endif present_in = . false . ! reset all values to false so everything gets written endif if ( present ( string )) then ! instead of command line arguments use another prototype string if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=' , STRING call prototype_to_dictionary ( string ) ! build dictionary from prototype else if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=' ,. true . call cmd_args_to_dictionary () endif if ( len ( G_remaining ) > 1 ) then ! if -- was in prototype then after -- on input return rest in this string itrim = len ( G_remaining ) if ( G_remaining ( itrim : itrim ) == ' ' ) then ! was adding a space at end as building it, but do not want to remove blanks G_remaining = G_remaining (: itrim - 1 ) endif remaining = G_remaining endif if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:NORMAL END' end subroutine prototype_and_cmd_args_to_nlist !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine expand_response ( name ) character ( len =* ), intent ( in ) :: name character ( len = :), allocatable :: prototype logical :: hold if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:START:NAME=' , name call get_prototype ( name , prototype ) if ( prototype /= '' ) then hold = G_append G_append = . false . if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=' , prototype call prototype_to_dictionary ( prototype ) ! build dictionary from prototype G_append = hold endif if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:END' end subroutine expand_response !=================================================================================================================================== subroutine get_prototype ( name , prototype ) ! process @name abbreviations character ( len =* ), intent ( in ) :: name character ( len = :), allocatable , intent ( out ) :: prototype character ( len = :), allocatable :: filename character ( len = :), allocatable :: os character ( len = :), allocatable :: plain_name character ( len = :), allocatable :: search_for integer :: lun integer :: ios integer :: itrim character ( len = 4096 ) :: line !x! assuming input never this long character ( len = 256 ) :: message character ( len = :), allocatable :: array (:) ! output array of tokens integer :: lines_processed lines_processed = 0 plain_name = name // ' ' plain_name = trim ( name ( 2 :)) os = '@' // get_env ( 'OSTYPE' , get_env ( 'OS' )) if ( G_DEBUG ) write ( * , gen ) 'GET_PROTOTYPE:OS=' , OS search_for = '' ! look for NAME.rsp and see if there is an @OS section in it and position to it and read if ( os /= '@' ) then search_for = os call find_and_read_response_file ( plain_name ) if ( lines_processed /= 0 ) return endif ! look for NAME.rsp and see if there is anything before an OS-specific section search_for = '' call find_and_read_response_file ( plain_name ) if ( lines_processed /= 0 ) return ! look for ARG0.rsp with @OS@NAME section in it and position to it if ( os /= '@' ) then search_for = os // name call find_and_read_response_file ( basename ( get_name (), suffix = . false .)) if ( lines_processed /= 0 ) return endif ! look for ARG0.rsp with a section called @NAME in it and position to it search_for = name call find_and_read_response_file ( basename ( get_name (), suffix = . false .)) if ( lines_processed /= 0 ) return write ( * , gen ) ' response name [' // trim ( name ) // '] not found' stop 1 contains !=================================================================================================================================== subroutine find_and_read_response_file ( rname ) ! search for a simple file named the same as the @NAME field with one entry assumed in it character ( len =* ), intent ( in ) :: rname character ( len = :), allocatable :: paths (:) character ( len = :), allocatable :: testpath character ( len = 256 ) :: message integer :: i integer :: ios prototype = '' ! look for NAME.rsp ! assume if have / or \\ a full filename was supplied to support ifort(1) if (( index ( rname , '/' ) /= 0. or . index ( rname , '\\') /= 0) .and. len(rname) > 1 )then filename=rname lun=fileopen(filename,message) if(lun /= -1)then call process_response() close(unit=lun,iostat=ios) endif return else filename=rname//' . rsp ' endif if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : FILENAME = ',filename ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories call split(get_env(' CLI_RESPONSE_PATH ',' ~ / . local / share / rsp '),paths) paths=[character(len=len(paths)) :: ' ',paths] if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : PATHS = ',paths do i=1,size(paths) testpath=join_path(paths(i),filename) lun=fileopen(testpath,message) if(lun /= -1)then if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : SEARCH_FOR = ',search_for if(search_for /= '') call position_response() ! set to end of file or where string was found call process_response() if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : LINES_PROCESSED = ',LINES_PROCESSED close(unit=lun,iostat=ios) if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : CLOSE : LUN = ',LUN,' IOSTAT = ',IOS if(lines_processed /= 0)exit endif enddo end subroutine find_and_read_response_file !=================================================================================================================================== subroutine position_response() integer :: ios line='' INFINITE: do read(unit=lun,fmt=' ( a ) ',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then if(G_DEBUG)write(*,gen)' < DEBUG > POSITION_RESPONSE : EOF ' backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)' < ERROR >* position_response * : '//trim(message) exit INFINITE endif line=adjustl(line) if(line == search_for)return enddo INFINITE end subroutine position_response !=================================================================================================================================== subroutine process_response() character(len=:),allocatable :: padded character(len=:),allocatable :: temp line='' lines_processed=0 INFINITE: do read(unit=lun,fmt=' ( a ) ',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)' < ERROR >* process_response * : '//trim(message) exit INFINITE endif line=trim(adjustl(line)) temp=line if(index(temp//' ',' # ') == 1)cycle if(temp /= '')then if(index(temp,' @ ') == 1.and.lines_processed /= 0)exit INFINITE call split(temp,array) ! get first word itrim=len_trim(array(1))+2 temp=temp(itrim:) PROCESS: select case(lower(array(1))) case(' comment ',' # ','') case(' system ',' !','$') if ( G_options_only ) exit PROCESS lines_processed = lines_processed + 1 call execute_command_line ( temp ) case ( 'options' , 'option' , '-' ) lines_processed = lines_processed + 1 prototype = prototype // ' ' // trim ( temp ) case ( 'print' , '>' , 'echo' ) if ( G_options_only ) exit PROCESS lines_processed = lines_processed + 1 write ( * , '(a)' ) trim ( temp ) case ( 'stop' ) if ( G_options_only ) exit PROCESS write ( * , '(a)' ) trim ( temp ) stop case default if ( array ( 1 )( 1 : 1 ) == '-' ) then ! assume these are simply options to support ifort(1) ! if starts with a single dash must assume a single argument ! and rest is value to support -Dname and -Ifile option ! which currently is not supported, so multiple short keywords ! does not work. Just a ifort(1) test at this point, so do not document if ( G_options_only ) exit PROCESS padded = trim ( line ) // ' ' if ( padded ( 2 : 2 ) == '-' ) then prototype = prototype // ' ' // trim ( line ) else prototype = prototype // ' ' // padded ( 1 : 2 ) // ' ' // trim ( padded ( 3 :)) endif lines_processed = lines_processed + 1 else if ( array ( 1 )( 1 : 1 ) == '@' ) cycle INFINITE !skip adjacent @ lines from first lines_processed = lines_processed + 1 write ( * , '(*(g0))' ) 'unknown response keyword [' , array ( 1 ), '] with options of [' , trim ( temp ), ']' endif end select PROCESS endif enddo INFINITE end subroutine process_response end subroutine get_prototype !=================================================================================================================================== function fileopen ( filename , message ) result ( lun ) character ( len =* ), intent ( in ) :: filename character ( len =* ), intent ( out ), optional :: message integer :: lun integer :: ios character ( len = 256 ) :: message_local ios = 0 message_local = '' open ( file = filename , newunit = lun ,& & form = 'formatted' , access = 'sequential' , action = 'read' ,& & position = 'rewind' , status = 'old' , iostat = ios , iomsg = message_local ) if ( ios /= 0 ) then lun =- 1 if ( present ( message )) then message = trim ( message_local ) else write ( * , gen ) trim ( message_local ) endif endif if ( G_DEBUG ) write ( * , gen ) 'FILEOPEN:FILENAME=' , filename , ' LUN=' , lun , ' IOS=' , IOS , ' MESSAGE=' , trim ( message_local ) end function fileopen !=================================================================================================================================== function get_env ( NAME , DEFAULT ) result ( VALUE ) character ( len =* ), intent ( in ) :: NAME character ( len =* ), intent ( in ), optional :: DEFAULT character ( len = :), allocatable :: VALUE integer :: howbig integer :: stat integer :: length ! get length required to hold value length = 0 if ( NAME /= '' ) then call get_environment_variable ( NAME , length = howbig , status = stat , trim_name = . true .) select case ( stat ) case ( 1 ) !x!print *, NAME, \" is not defined in the environment. Strange...\" VALUE = '' case ( 2 ) !x!print *, \"This processor doesn't support environment variables. Boooh!\" VALUE = '' case default ! make string to hold value of sufficient size if ( allocated ( value )) deallocate ( value ) allocate ( character ( len = max ( howbig , 1 )) :: VALUE ) ! get value call get_environment_variable ( NAME , VALUE , status = stat , trim_name = . true .) if ( stat /= 0 ) VALUE = '' end select else VALUE = '' endif if ( VALUE == '' . and . present ( DEFAULT )) VALUE = DEFAULT end function get_env !=================================================================================================================================== function join_path ( a1 , a2 , a3 , a4 , a5 ) result ( path ) ! Construct path by joining strings with os file separator ! character ( len =* ), intent ( in ) :: a1 , a2 character ( len =* ), intent ( in ), optional :: a3 , a4 , a5 character ( len = :), allocatable :: path character ( len = 1 ) :: filesep filesep = separator () if ( a1 /= '' ) then path = trim ( a1 ) // filesep // trim ( a2 ) else path = trim ( a2 ) endif if ( present ( a3 )) path = path // filesep // trim ( a3 ) if ( present ( a4 )) path = path // filesep // trim ( a4 ) if ( present ( a5 )) path = path // filesep // trim ( a5 ) path = adjustl ( path // ' ' ) call substitute ( path , filesep // filesep , '' , start = 2 ) ! some systems allow names starting with '//' or '\\\\' path = trim ( path ) end function join_path !=================================================================================================================================== function get_name () result ( name ) ! get the pathname of arg0 character ( len = :), allocatable :: arg0 integer :: arg0_length integer :: istat character ( len = 4096 ) :: long_name character ( len = :), allocatable :: name arg0_length = 0 name = '' long_name = '' call get_command_argument ( 0 , length = arg0_length , status = istat ) if ( istat == 0 ) then if ( allocated ( arg0 )) deallocate ( arg0 ) allocate ( character ( len = arg0_length ) :: arg0 ) call get_command_argument ( 0 , arg0 , status = istat ) if ( istat == 0 ) then inquire ( file = arg0 , iostat = istat , name = long_name ) name = trim ( long_name ) else name = arg0 endif endif end function get_name !=================================================================================================================================== function basename ( path , suffix ) result ( base ) ! Extract filename from path with/without suffix ! character ( * ), intent ( In ) :: path logical , intent ( in ), optional :: suffix character (:), allocatable :: base character (:), allocatable :: file_parts (:) logical :: with_suffix if (. not . present ( suffix )) then with_suffix = . true . else with_suffix = suffix endif if ( with_suffix ) then call split ( path , file_parts , delimiters = '\\/' ) if ( size ( file_parts ) > 0 ) then base = trim ( file_parts ( size ( file_parts ))) else base = '' endif else call split ( path , file_parts , delimiters = '\\/.' ) if ( size ( file_parts ) >= 2 ) then base = trim ( file_parts ( size ( file_parts ) - 1 )) elseif ( size ( file_parts ) == 1 ) then base = trim ( file_parts ( 1 )) else base = '' endif endif end function basename !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function separator () result ( sep ) !> !!##NAME !! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function separator() result(sep) !! !! character(len=1) :: sep !! !!##DESCRIPTION !! First testing for the existence of \"/.\", then if that fails a list !! of variable names assumed to contain directory paths {PATH|HOME} are !! examined first for a backslash, then a slash. Assuming basically the !! choice is a ULS or MSWindows system, and users can do weird things like !! put a backslash in a ULS path and break it. !! !! Therefore can be very system dependent. If the queries fail the !! default returned is \"/\". !! !!##EXAMPLE !! !! sample usage !! !! program demo_separator !! use M_io, only : separator !! implicit none !! write(*,*)'separator=',separator() !! end program demo_separator ! use the pathname returned as arg0 to determine pathname separator integer :: ios integer :: i logical :: existing = . false . character ( len = 1 ) :: sep !x!IFORT BUG:character(len=1),save :: sep_cache=' ' integer , save :: isep =- 1 character ( len = 4096 ) :: name character ( len = :), allocatable :: envnames (:) ! NOTE: A parallel code might theoretically use multiple OS !x!FORT BUG:if(sep_cache /= ' ')then ! use cached value. !x!FORT BUG: sep=sep_cache !x!FORT BUG: return !x!FORT BUG:endif if ( isep /= - 1 ) then ! use cached value. sep = char ( isep ) return endif FOUND : block ! simple, but does not work with ifort ! most MSWindows environments see to work with backslash even when ! using POSIX filenames to do not rely on '\\.'. inquire ( file = '/.' , exist = existing , iostat = ios , name = name ) if ( existing . and . ios == 0 ) then sep = '/' exit FOUND endif ! check variables names common to many platforms that usually have a ! directory path in them although a ULS file can contain a backslash ! and vice-versa (eg. \"touch A\\\\B\\\\C\"). Removed HOMEPATH because it ! returned a name with backslash on CygWin, Mingw, WLS even when using ! POSIX filenames in the environment. envnames = [ character ( len = 10 ) :: 'PATH' , 'HOME' ] do i = 1 , size ( envnames ) if ( index ( get_env ( envnames ( i )), '\\') /= 0)then sep=' \\ ' exit FOUND elseif(index(get_env(envnames(i)),' / ') /= 0)then sep=' / ' exit FOUND endif enddo write(*,*)' < WARNING > unknown system directory path separator ' sep=' \\ ' endblock FOUND !x!IFORT BUG:sep_cache=sep isep=ichar(sep) end function separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine cmd_args_to_dictionary() ! convert command line arguments to dictionary entries !x!logical :: guess_if_value integer :: pointer character(len=:),allocatable :: lastkeyword integer :: i, jj, kk integer :: ilength, istatus, imax character(len=1) :: letter character(len=:),allocatable :: current_argument character(len=:),allocatable :: current_argument_padded character(len=:),allocatable :: dummy character(len=:),allocatable :: oldvalue logical :: nomore logical :: next_mandatory if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : START ' next_mandatory=.false. nomore=.false. pointer=0 lastkeyword=' ' G_keyword_single_letter=.true. i=1 GET_ARGS: do while (get_next_argument()) ! insert and replace entries if( current_argument == ' - ' .and. nomore .eqv. .true. )then ! sort of elseif( current_argument == ' - ')then ! sort of current_argument=' \"stdin\" ' endif if( current_argument == ' -- ' .and. nomore .eqv. .true. )then ! -- was already encountered elseif( current_argument == ' -- ' )then ! everything after this goes into the unnamed array nomore=.true. pointer=0 if(G_remaining_option_allowed)then G_remaining_on=.true. endif cycle GET_ARGS endif dummy=current_argument//' ' current_argument_padded=current_argument//' ' !x!guess_if_value=maybe_value() if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == ' -- ')then ! beginning of long word G_keyword_single_letter=.false. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(3:),pointer) if(pointer <= 0)then if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call print_dictionary(' UNKNOWN LONG KEYWORD : '//current_argument) call mystop(1) return endif lastkeyword=trim(current_argument_padded(3:)) next_mandatory=mandatory(pointer) elseif(.not.next_mandatory & & .and..not.nomore & & .and.current_argument_padded(1:1) == ' - ' & & .and.index(\"0123456789.\",dummy(2:2)) == 0)then ! short word G_keyword_single_letter=.true. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(2:),pointer) if(pointer <= 0)then ! name not found jj=len(current_argument) if(G_STRICT.and.jj > 2)then ! in strict mode this might be multiple single-character values do kk=2,jj letter=current_argument_padded(kk:kk) call locate_key(letter,pointer) if(pointer > 0)then call update(keywords(pointer),' T ') else call print_dictionary(' UNKNOWN COMPOUND SHORT KEYWORD : '//letter//' in '//current_argument) if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call mystop(2) return endif current_argument=' - '//current_argument_padded(jj:jj) enddo else call print_dictionary(' UNKNOWN SHORT KEYWORD : '//current_argument) if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call mystop(2) return endif endif lastkeyword=trim(current_argument_padded(2:)) next_mandatory=mandatory(pointer) elseif(pointer == 0)then ! unnamed arguments if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//' \"\" ' elseif(current_argument(1:1) == ' - ')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//' \"'//current_argument//'\" ' else G_remaining=G_remaining//' \"'//current_argument//'\" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ',' @ ') == 1.and.G_response)then if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : 1 : CALL EXPAND_RESPONSE : CURRENT_ARGUMENT = ',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif else oldvalue=get(keywords(pointer))//' ' if(oldvalue(1:1) == ' \"')then current_argument=quote(current_argument(:ilength)) endif if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter if(current_argument /= ' ')then if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'\"\" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'\" '//current_argument//' \" ' else G_remaining=G_remaining//'\" '//current_argument//' \" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif endif current_argument='T' endif call update(keywords(pointer),current_argument) pointer=0 lastkeyword='' next_mandatory=.false. endif enddo GET_ARGS if(lastkeyword /= '')then call ifnull() endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:NORMAL END' contains subroutine ifnull() oldvalue=get(lastkeyword)//' ' if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then call update(lastkeyword,'T') elseif(oldvalue(1:1) == '\" ')then call update(lastkeyword,' \" \" ') else call update(lastkeyword,' ') endif end subroutine ifnull function get_next_argument() ! ! get next argument from command line into allocated variable current_argument ! logical,save :: hadequal=.false. character(len=:),allocatable,save :: right_hand_side logical :: get_next_argument integer :: iright integer :: iequal if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax current_argument=right_hand_side right_hand_side='' hadequal=.false. get_next_argument=.true. ilength=len(current_argument) return endif if(i>command_argument_count())then get_next_argument=.false. return else get_next_argument=.true. endif call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)' * prototype_and_cmd_args_to_nlist * error obtaining argument ',i,& &' status = ',istatus,& &' length = ',ilength get_next_argument=.false. else ilength=max(ilength,1) if(allocated(current_argument))deallocate(current_argument) allocate(character(len=ilength) :: current_argument) call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)' * prototype_and_cmd_args_to_nlist * error obtaining argument ',i,& &' status = ',istatus,& &' length = ',ilength,& &' target length = ',len(current_argument) get_next_argument=.false. endif ! if an argument keyword and an equal before a space split on equal and save right hand side for next call if(nomore)then elseif( len(current_argument) == 0)then else iright=index(current_argument,' ') if(iright == 0)iright=len(current_argument) iequal=index(current_argument(:iright),' = ') if(next_mandatory)then elseif(iequal /= 0.and.current_argument(1:1) == ' - ')then if(iequal /= len(current_argument))then right_hand_side=current_argument(iequal+1:) else right_hand_side='' endif hadequal=.true. current_argument=current_argument(:iequal-1) endif endif endif i=i+1 end function get_next_argument function maybe_value() ! if previous keyword value type is a string and it was ! given a null string because this value starts with a - ! try to see if this is a string value starting with a - ! to try to solve the vexing problem of values starting ! with a dash. logical :: maybe_value integer :: pointer character(len=:),allocatable :: oldvalue oldvalue=get(lastkeyword)//' ' if(current_argument_padded(1:1) /= ' - ')then maybe_value=.true. elseif(oldvalue(1:1) /= ' \"')then maybe_value=.false. elseif(index(current_argument,' ') /= 0)then maybe_value=.true. elseif(scan(current_argument,\" ,:; !@#$%^&*+=()[]{}\\|'\"\"./> !!##NAME !! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary !! created by calls to set_args(3f) !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine print_dictionary(header,stop) !! !! character(len=*),intent(in),optional :: header !! logical,intent(in),optional :: stop !!##DESCRIPTION !! Print the internal dictionary created by calls to set_args(3f). !! This routine is intended to print the state of the argument list !! if an error occurs in using the set_args(3f) procedure. !!##OPTIONS !! HEADER label to print before printing the state of the command !! argument list. !! STOP logical value that if true stops the program after displaying !! the dictionary. !!##EXAMPLE !! !! !! !! Typical usage: !! !! program demo_print_dictionary !! use M_CLI2, only : set_args, get_args !! implicit none !! real :: x, y, z !! call set_args('-x 10 -y 20 -z 30') !! call get_args('x',x,'y',y,'z',z) !! ! all done cracking the command line; use the values in your program. !! write(*,*)x,y,z !! end program demo_print_dictionary !! !! Sample output !! !! Calling the sample program with an unknown parameter or the --usage !! switch produces the following: !! !! $ ./demo_print_dictionary -A !! UNKNOWN SHORT KEYWORD: -A !! KEYWORD PRESENT VALUE !! z F [3] !! y F [2] !! x F [1] !! help F [F] !! version F [F] !! usage F [F] !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine print_dictionary ( header , stop ) character ( len =* ), intent ( in ), optional :: header logical , intent ( in ), optional :: stop integer :: i if ( G_QUIET ) return if ( present ( header )) then if ( header /= '' ) then write ( warn , '(a)' ) header endif endif if ( allocated ( keywords )) then if ( size ( keywords ) > 0 ) then write ( warn , '(a,1x,a,1x,a,1x,a)' ) atleast ( 'KEYWORD' , max ( len ( keywords ), 8 )), 'SHORT' , 'PRESENT' , 'VALUE' write ( warn , '(*(a,1x,a5,1x,l1,8x,\"[\",a,\"]\",/))' ) & & ( atleast ( keywords ( i ), max ( len ( keywords ), 8 )), shorts ( i ), present_in ( i ), values ( i )(: counts ( i )), i = 1 , size ( keywords )) endif endif if ( allocated ( unnamed )) then if ( size ( unnamed ) > 0 ) then write ( warn , '(a)' ) 'UNNAMED' write ( warn , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif endif if ( allocated ( args )) then if ( size ( args ) > 0 ) then write ( warn , '(a)' ) 'ARGS' write ( warn , '(i6.6,3a)' )( i , '[' , args ( i ), ']' , i = 1 , size ( args )) endif endif if ( G_remaining /= '' ) then write ( warn , '(a)' ) 'REMAINING' write ( warn , '(a)' ) G_remaining endif if ( present ( stop )) then if ( stop ) call mystop ( 5 ) endif end subroutine print_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== FUNCTION strtok ( source_string , itoken , token_start , token_end , delimiters ) result ( strtok_status ) ! JSU- 20151030 ! ident_6=\"@(#) M_CLI2 strtok(3f) Tokenize a string\" character ( len =* ), intent ( in ) :: source_string ! Source string to tokenize. character ( len =* ), intent ( in ) :: delimiters ! list of separator characters. May change between calls integer , intent ( inout ) :: itoken ! token count since started logical :: strtok_status ! returned value integer , intent ( out ) :: token_start ! beginning of token found if function result is .true. integer , intent ( inout ) :: token_end ! end of token found if function result is .true. integer :: isource_len !---------------------------------------------------------------------------------------------------------------------------- ! calculate where token_start should start for this pass if ( itoken <= 0 ) then ! this is assumed to be the first call token_start = 1 else ! increment start to previous end + 1 token_start = token_end + 1 endif !---------------------------------------------------------------------------------------------------------------------------- isource_len = len ( source_string ) ! length of input string !---------------------------------------------------------------------------------------------------------------------------- if ( token_start > isource_len ) then ! user input error or at end of string token_end = isource_len ! assume end of token is end of string until proven otherwise so it is set strtok_status = . false . return endif !---------------------------------------------------------------------------------------------------------------------------- ! find beginning of token do while ( token_start <= isource_len ) ! step thru each character to find next delimiter, if any if ( index ( delimiters , source_string ( token_start : token_start )) /= 0 ) then token_start = token_start + 1 else exit endif enddo !---------------------------------------------------------------------------------------------------------------------------- token_end = token_start do while ( token_end <= isource_len - 1 ) ! step thru each character to find next delimiter, if any if ( index ( delimiters , source_string ( token_end + 1 : token_end + 1 )) /= 0 ) then ! found a delimiter in next character exit endif token_end = token_end + 1 enddo !---------------------------------------------------------------------------------------------------------------------------- if ( token_start > isource_len ) then ! determine if finished strtok_status = . false . ! flag that input string has been completely processed else itoken = itoken + 1 ! increment count of tokens found strtok_status = . true . ! flag more tokens may remain endif !---------------------------------------------------------------------------------------------------------------------------- end function strtok !==================================================================================================================================! !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !==================================================================================================================================! !> !!##NAME !! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing !! command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! get_args(3f) and its convenience functions: !! !! use M_CLI2, only : get_args !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! !! subroutine get_args(name,value,delimiters) !! !! character(len=*),intent(in) :: name !! !! type(${TYPE}),allocatable,intent(out) :: value(:) !! ! or !! type(${TYPE}),allocatable,intent(out) :: value !! !! character(len=*),intent(in),optional :: delimiters !! !! where ${TYPE} may be from the set !! {real,doubleprecision,integer,logical,complex,character(len=:)} !!##DESCRIPTION !! !! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) !! has been called. For fixed-length CHARACTER variables !! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! GET_ARGS_FIXED_SIZE(3f). !! !! As a convenience multiple pairs of keywords and variables may be !! specified if and only if all the values are scalars and the CHARACTER !! variables are fixed-length or pre-allocated. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! VALUE variable to hold returned value. The kind of the value !! is used to determine the type of returned value. May !! be a scalar or allocatable array. If type is CHARACTER !! the scalar must have an allocatable length. !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##CONVENIENCE FUNCTIONS !! !! There are convenience functions that are replacements for calls to !! get_args(3f) for each supported default intrinsic type !! !! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), !! cget(3f) !! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), !! sgets(3f), cgets(3f) !! !! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, !! S for string (CHARACTER), and C for COMPLEX. !! !! If the functions are called with no argument they will return the !! UNNAMED array converted to the specified type. !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_get_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! implicit none !! integer :: i !! ! DEFINE ARGS !! real :: x, y, z !! real,allocatable :: p(:) !! character(len=:),allocatable :: title !! logical :: l, lbig !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o only quote strings and use double-quotes !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1,-2,-3 & !! & --title \"my title\" & !! & -l F -L F & !! & --label \" \" & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! ! SCALARS !! call get_args('x',x,'y',y,'z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! ! ALLOCATABLE STRING !! call get_args('title',title) !! ! NON-ALLOCATABLE ARRAYS !! call get_args('p',p) !! ! USE VALUES !! write(*,'(1x,g0,\"=\",g0)')'x',x, 'y',y, 'z',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_get_args !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-length string when parsing command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_length(name,value) !! !! character(len=:),allocatable :: value !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! GET_ARGS_fixed_length(3f) returns the value of a string !! keyword when the string value is a fixed-length CHARACTER !! variable. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned value. !! Must be a fixed-length CHARACTER variable. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_length !! use M_CLI2, only : set_args, get_args_fixed_length !! implicit none !! ! DEFINE ARGS !! character(len=80) :: title !! call set_args(' & !! & --title \"my title\" & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args_fixed_length('title',title) !! ! USE VALUES !! write(*,*)'title=',title !! end program demo_get_args_fixed_length !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-size array when parsing command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_size(name,value) !! !! [real|doubleprecision|integer|logical|complex] :: value(NNN) !! or !! character(len=MMM) :: value(NNN) !! !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for !! fixed-size arrays after SET_ARGS(3f) has been called. !! On input on the command line all values of the array must !! be specified. !! !!##OPTIONS !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned values. The kind of the value !! is used to determine the type of returned value. Must be !! a fixed-size array. If type is CHARACTER the length must !! also be fixed. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_size !! use M_CLI2, only : set_args, get_args_fixed_size !! implicit none !! integer,parameter :: dp=kind(0.0d0) !! ! DEFINE ARGS !! real :: x(2) !! real(kind=dp) :: y(2) !! integer :: p(3) !! character(len=80) :: title(1) !! logical :: l(4), lbig(4) !! complex :: cmp(2) !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o only quote strings !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 10.0,20.0 & !! & -y 11.0,22.0 & !! & -p -1,-2,-3 & !! & --title \"my title\" & !! & -l F,T,F,T -L T,F,T,F & !! & --cmp 111,222.0,333.0e0,4444 & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args_fixed_size('x',x) !! call get_args_fixed_size('y',y) !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('title',title) !! call get_args_fixed_size('l',l) !! call get_args_fixed_size('L',lbig) !! call get_args_fixed_size('cmp',cmp) !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'cmp=',cmp !! end program demo_get_args_fixed_size !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine get_fixedarray_class ( keyword , generic , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary class ( * ) :: generic (:) character ( len =* ), intent ( in ), optional :: delimiters select type ( generic ) type is ( character ( len =* )); call get_fixedarray_fixed_length_c ( keyword , generic , delimiters ) type is ( integer ); call get_fixedarray_i ( keyword , generic , delimiters ) type is ( real ); call get_fixedarray_r ( keyword , generic , delimiters ) type is ( complex ); call get_fixed_size_complex ( keyword , generic , delimiters ) type is ( real ( kind = dp )); call get_fixedarray_d ( keyword , generic , delimiters ) type is ( logical ); call get_fixedarray_l ( keyword , generic , delimiters ) class default call mystop ( - 7 , '*get_fixedarray_class* crud -- procedure does not know about this type' ) end select end subroutine get_fixedarray_class !=================================================================================================================================== ! return allocatable arrays !=================================================================================================================================== subroutine get_anyarray_l ( keyword , larray , delimiters ) ! ident_7=\"@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)\" character ( len =* ), intent ( in ) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve logical , allocatable :: larray (:) ! convert value to an array character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: carray (:) ! convert value to an array character ( len = :), allocatable :: val integer :: i integer :: place integer :: iichar ! point to first character of word unless first character is \".\" call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if string was found val = values ( place )(: counts ( place )) call split ( adjustl ( upper ( val )), carray , delimiters = delimiters ) ! convert value to uppercase, trimmed; then parse into array else call journal ( 'sc' , '*get_anyarray_l* unknown keyword ' // keyword ) call mystop ( 8 , '*get_anyarray_l* unknown keyword ' // keyword ) if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( 0 )) return endif if ( size ( carray ) > 0 ) then ! if not a null string if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( size ( carray ))) ! allocate output array do i = 1 , size ( carray ) larray ( i ) = . false . ! initialize return value to .false. if ( carray ( i )( 1 : 1 ) == '.' ) then ! looking for fortran logical syntax .STRING. iichar = 2 else iichar = 1 endif select case ( carray ( i )( iichar : iichar )) ! check word to see if true or false case ( 'T' , 'Y' , ' ' ); larray ( i ) = . true . ! anything starting with \"T\" or \"Y\" or a blank is TRUE (true,yes,...) case ( 'F' , 'N' ); larray ( i ) = . false . ! assume this is false or no case default call journal ( 'sc' , \"*get_anyarray_l* bad logical expression for \" // trim ( keyword ) // '=' // carray ( i )) end select enddo else ! for a blank string return one T if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( 1 )) ! allocate output array larray ( 1 ) = . true . endif end subroutine get_anyarray_l !=================================================================================================================================== subroutine get_anyarray_d ( keyword , darray , delimiters ) ! ident_8=\"@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)\" character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ), allocatable , intent ( out ) :: darray (:) ! function type character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: carray (:) ! convert value to an array using split(3f) integer :: i integer :: place integer :: ierr character ( len = :), allocatable :: val !----------------------------------------------------------------------------------------------------------------------------------- call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if string was found val = values ( place )(: counts ( place )) val = replace_str ( val , '(' , '' ) val = replace_str ( val , ')' , '' ) call split ( val , carray , delimiters = delimiters ) ! find value associated with keyword and split it into an array else call journal ( 'sc' , '*get_anyarray_d* unknown keyword ' // keyword ) call mystop ( 9 , '*get_anyarray_d* unknown keyword ' // keyword ) if ( allocated ( darray )) deallocate ( darray ) allocate ( darray ( 0 )) return endif if ( allocated ( darray )) deallocate ( darray ) allocate ( darray ( size ( carray ))) ! create the output array do i = 1 , size ( carray ) call a2d ( carray ( i ), darray ( i ), ierr ) ! convert the string to a numeric value if ( ierr /= 0 ) then call mystop ( 10 , '*get_anyarray_d* unreadable value ' // carray ( i ) // ' for keyword ' // keyword ) endif enddo end subroutine get_anyarray_d !=================================================================================================================================== subroutine get_anyarray_i ( keyword , iarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer , allocatable :: iarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type call get_anyarray_d ( keyword , darray , delimiters ) iarray = nint ( darray ) end subroutine get_anyarray_i !=================================================================================================================================== subroutine get_anyarray_r ( keyword , rarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real , allocatable :: rarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type call get_anyarray_d ( keyword , darray , delimiters ) rarray = real ( darray ) end subroutine get_anyarray_r !=================================================================================================================================== subroutine get_anyarray_x ( keyword , xarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex ( kind = sp ), allocatable :: xarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: half , sz , i call get_anyarray_d ( keyword , darray , delimiters ) sz = size ( darray ) half = sz / 2 if ( sz /= half + half ) then call journal ( 'sc' , '*get_anyarray_x* uneven number of values defining complex value ' // keyword ) call mystop ( 11 , '*get_anyarray_x* uneven number of values defining complex value ' // keyword ) if ( allocated ( xarray )) deallocate ( xarray ) allocate ( xarray ( 0 )) endif !x!================================================================================================ !x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2))) if ( allocated ( xarray )) deallocate ( xarray ) allocate ( xarray ( half )) do i = 1 , sz , 2 xarray (( i + 1 ) / 2 ) = cmplx ( darray ( i ), darray ( i + 1 ), kind = sp ) enddo !x!================================================================================================ end subroutine get_anyarray_x !=================================================================================================================================== subroutine get_anyarray_c ( keyword , strings , delimiters ) ! ident_8=\"@(#)M_CLI2::get_anyarray_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len = :), allocatable :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters integer :: place character ( len = :), allocatable :: val call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , strings , delimiters = delimiters ) ! find value associated with keyword and split it into an array else call journal ( 'sc' , '*get_anyarray_c* unknown keyword ' // keyword ) call mystop ( 12 , '*get_anyarray_c* unknown keyword ' // keyword ) if ( allocated ( strings )) deallocate ( strings ) allocate ( character ( len = 0 ) :: strings ( 0 )) endif end subroutine get_anyarray_c !=================================================================================================================================== !=================================================================================================================================== subroutine get_args_fixed_length_a_array ( keyword , strings , delimiters ) ! ident_9=\"@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len =* ), allocatable :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: strings_a (:) integer :: place character ( len = :), allocatable :: val integer :: ibug call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , strings_a , delimiters = delimiters ) ! find value associated with keyword and split it into an array if ( len ( strings_a ) <= len ( strings ) ) then strings = strings_a else ibug = len ( strings ) call journal ( 'sc' , '*get_args_fixed_length_a_array* values too long. Longest is' , len ( strings_a ), 'allowed is' , ibug ) write ( * , '(\"strings=\",3x,*(a,1x))' ) strings call journal ( 'sc' , '*get_args_fixed_length_a_array* keyword=' // keyword ) call mystop ( 13 , '*get_args_fixed_length_a_array* keyword=' // keyword ) strings = [ character ( len = len ( strings )) :: ] endif else call journal ( 'sc' , '*get_args_fixed_length_a_array* unknown keyword ' // keyword ) call mystop ( 14 , '*get_args_fixed_length_a_array* unknown keyword ' // keyword ) strings = [ character ( len = len ( strings )) :: ] endif end subroutine get_args_fixed_length_a_array !=================================================================================================================================== ! return non-allocatable arrays !=================================================================================================================================== subroutine get_fixedarray_i ( keyword , iarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer :: iarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_d ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( iarray , dim = 1 ) == dsize ) then iarray = nint ( darray ) else ibug = size ( iarray ) call journal ( 'sc' , '*get_fixedarray_i* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 33 ) iarray = 0 endif end subroutine get_fixedarray_i !=================================================================================================================================== subroutine get_fixedarray_r ( keyword , rarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real :: rarray (:) character ( len =* ), intent ( in ), optional :: delimiters real , allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_r ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( rarray , dim = 1 ) == dsize ) then rarray = darray else ibug = size ( rarray ) call journal ( 'sc' , '*get_fixedarray_r* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 33 ) rarray = 0.0 endif end subroutine get_fixedarray_r !=================================================================================================================================== subroutine get_fixed_size_complex ( keyword , xarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex :: xarray (:) character ( len =* ), intent ( in ), optional :: delimiters complex , allocatable :: darray (:) ! function type integer :: half , sz integer :: dsize integer :: ibug call get_anyarray_x ( keyword , darray , delimiters ) dsize = size ( darray ) sz = dsize * 2 half = sz / 2 if ( sz /= half + half ) then call journal ( 'sc' , '*get_fixed_size_complex* uneven number of values defining complex value ' // keyword ) call mystop ( 15 , '*get_fixed_size_complex* uneven number of values defining complex value ' // keyword ) xarray = 0 return endif if ( ubound ( xarray , dim = 1 ) == dsize ) then xarray = darray else ibug = size ( xarray ) call journal ( 'sc' , '*get_fixed_size_complex* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 34 ) xarray = cmplx ( 0.0 , 0.0 ) endif end subroutine get_fixed_size_complex !=================================================================================================================================== subroutine get_fixedarray_d ( keyword , darr , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ) :: darr (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_d ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( darr , dim = 1 ) == dsize ) then darr = darray else ibug = size ( darr ) call journal ( 'sc' , '*get_fixedarray_d* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 35 ) darr = 0.0d0 endif end subroutine get_fixedarray_d !=================================================================================================================================== subroutine get_fixedarray_l ( keyword , larray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary logical :: larray (:) character ( len =* ), intent ( in ), optional :: delimiters logical , allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_l ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( larray , dim = 1 ) == dsize ) then larray = darray else ibug = size ( larray ) call journal ( 'sc' , '*get_fixedarray_l* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 36 ) larray = . false . endif end subroutine get_fixedarray_l !=================================================================================================================================== subroutine get_fixedarray_fixed_length_c ( keyword , strings , delimiters ) ! ident_10=\"@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ) :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: str (:) character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary integer :: place integer :: ssize integer :: ibug character ( len = :), allocatable :: val call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , str , delimiters = delimiters ) ! find value associated with keyword and split it into an array ssize = size ( str ) if ( ssize == size ( strings )) then strings (: ssize ) = str else ibug = size ( strings ) call journal ( 'sc' , '*get_fixedarray_fixed_length_c* wrong number of values for keyword' ,& & keyword , 'got' , ssize , 'expected ' , ibug ) !,ubound(strings,dim=1) call print_dictionary ( 'USAGE:' ) call mystop ( 30 , '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) strings = '' endif else call journal ( 'sc' , '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) call mystop ( 16 , '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) strings = '' endif end subroutine get_fixedarray_fixed_length_c !=================================================================================================================================== ! return scalars !=================================================================================================================================== subroutine get_scalar_d ( keyword , d ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ) :: d real ( kind = dp ), allocatable :: darray (:) ! function type integer :: ibug call get_anyarray_d ( keyword , darray ) if ( size ( darray ) == 1 ) then d = darray ( 1 ) else ibug = size ( darray ) call journal ( 'sc' , '*get_anyarray_d* incorrect number of values for keyword' , keyword , 'expected one found' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 31 , '*get_anyarray_d* incorrect number of values for keyword' // keyword // 'expected one' ) endif end subroutine get_scalar_d !=================================================================================================================================== subroutine get_scalar_real ( keyword , r ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real , intent ( out ) :: r real ( kind = dp ) :: d call get_scalar_d ( keyword , d ) r = real ( d ) end subroutine get_scalar_real !=================================================================================================================================== subroutine get_scalar_i ( keyword , i ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer , intent ( out ) :: i real ( kind = dp ) :: d call get_scalar_d ( keyword , d ) i = nint ( d ) end subroutine get_scalar_i !=================================================================================================================================== subroutine get_scalar_anylength_c ( keyword , string ) ! ident_11=\"@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len = :), allocatable , intent ( out ) :: string integer :: place call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return string string = unquote ( values ( place )(: counts ( place ))) else call mystop ( 17 , '*get_anyarray_c* unknown keyword ' // keyword ) call journal ( 'sc' , '*get_anyarray_c* unknown keyword ' // keyword ) string = '' endif end subroutine get_scalar_anylength_c !=================================================================================================================================== elemental impure subroutine get_args_fixed_length_scalar_c ( keyword , string ) ! ident_12=\"@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len =* ), intent ( out ) :: string integer :: place integer :: unlen integer :: ibug call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return string string = unquote ( values ( place )(: counts ( place ))) else call mystop ( 18 , '*get_args_fixed_length_scalar_c* unknown keyword ' // keyword ) string = '' endif unlen = len_trim ( unquote ( values ( place )(: counts ( place )))) if ( unlen > len ( string )) then ibug = len ( string ) call journal ( 'sc' , '*get_args_fixed_length_scalar_c* value too long for' , keyword , 'allowed is' , ibug ,& & 'input string [' , values ( place ), '] is' , unlen ) call mystop ( 19 , '*get_args_fixed_length_scalar_c* value too long' ) string = '' endif end subroutine get_args_fixed_length_scalar_c !=================================================================================================================================== subroutine get_scalar_complex ( keyword , x ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex , intent ( out ) :: x real ( kind = dp ) :: d ( 2 ) call get_fixedarray_d ( keyword , d ) x = cmplx ( d ( 1 ), d ( 2 ), kind = sp ) end subroutine get_scalar_complex !=================================================================================================================================== subroutine get_scalar_logical ( keyword , l ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary logical :: l logical , allocatable :: larray (:) ! function type integer :: ibug l = . false . call get_anyarray_l ( keyword , larray ) if (. not . allocated ( larray ) ) then call journal ( 'sc' , '*get_scalar_logical* expected one value found not allocated' ) call mystop ( 37 , '*get_scalar_logical* incorrect number of values for keyword ' // keyword ) elseif ( size ( larray ) == 1 ) then l = larray ( 1 ) else ibug = size ( larray ) call journal ( 'sc' , '*get_scalar_logical* expected one value found' , ibug ) call mystop ( 21 , '*get_scalar_logical* incorrect number of values for keyword ' // keyword ) endif end subroutine get_scalar_logical !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE !use M_list, only : insert, locate, remove, replace !use M_journal, only : JOURNAL !use M_args, only : LONGEST_COMMAND_ARGUMENT ! routines extracted from other modules !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest !! argument on command line !! (LICENSE:PD) !!##SYNOPSIS !! !! function longest_command_argument() result(ilongest) !! !! integer :: ilongest !! !!##DESCRIPTION !! length of longest argument on command line. Useful when allocating !! storage for holding arguments. !!##RESULT !! longest_command_argument length of longest command argument !!##EXAMPLE !! !! Sample program !! !! program demo_longest_command_argument !! use M_args, only : longest_command_argument !! write(*,*)'longest argument is ',longest_command_argument() !! end program demo_longest_command_argument !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain function longest_command_argument () result ( ilongest ) integer :: i integer :: ilength integer :: istatus integer :: ilongest ilength = 0 ilongest = 0 GET_LONGEST : do i = 1 , command_argument_count () ! loop throughout command line arguments to find longest call get_command_argument ( number = i , length = ilength , status = istatus ) ! get next argument if ( istatus /= 0 ) then ! on error write ( warn , * ) '*prototype_and_cmd_args_to_nlist* error obtaining length for argument ' , i exit GET_LONGEST elseif ( ilength > 0 ) then ilongest = max ( ilongest , ilength ) endif enddo GET_LONGEST end function longest_command_argument !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine journal ( where , g0 , g1 , g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 , ga , gb , gc , gd , ge , gf , gg , gh , gi , gj , sep ) ! ident_13=\"@(#) M_CLI2 journal(3f) writes a message to a string composed of any standard scalar types\" character ( len =* ), intent ( in ) :: where class ( * ), intent ( in ) :: g0 class ( * ), intent ( in ), optional :: g1 , g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 class ( * ), intent ( in ), optional :: ga , gb , gc , gd , ge , gf , gg , gh , gi , gj character ( len =* ), intent ( in ), optional :: sep write ( * , '(a)' ) str ( g0 , g1 , g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 , ga , gb , gc , gd , ge , gf , gg , gh , gi , gj , sep ) end subroutine journal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! str(3f) - [M_CLI2] converts any standard scalar type to a string !! (LICENSE:PD) !!##SYNOPSIS !! !! function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep) !! !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 !! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! character(len=*),intent(in),optional :: sep !! character,len=(:),allocatable :: str !! !!##DESCRIPTION !! str(3f) builds a space-separated string from up to twenty scalar values. !! !!##OPTIONS !! g[0-9a-j] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! Optionally, all the generic values can be !! single-dimensioned arrays. Currently, mixing scalar !! arguments and array arguments is not supported. !! !! sep separator to place between values. Defaults to a space. !!##RETURNS !! str description to print !!##EXAMPLES !! !! Sample program: !! !! program demo_str !! use M_CLI2, only : str !! implicit none !! character(len=:),allocatable :: pr !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! pr=str('HUGE(3f) integers',huge(0),'and real',& !! & huge(0.0),'and double',huge(0.0d0)) !! write(*,'(a)')pr !! pr=str('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) !! write(*,'(a)')pr !! pr=str('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! write(*,'(a)')pr !! pr=str('complex :',cmplx(huge(0.0),tiny(0.0)) ) !! write(*,'(a)')pr !! !! ! create a format on the fly !! biggest=huge(0) !! frmt=str('(*(i',nint(log10(real(biggest))),':,1x))',sep=' ') !! write(*,*)'format=',frmt !! !! ! although it will often work, using str(3f) in an I/O statement !! ! is not recommended because if an error occurs str(3f) will try !! ! to write while part of an I/O statement which not all compilers !! ! can handle and is currently non-standard !! write(*,*)str('program will now stop') !! !! end program demo_str !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and !! double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function msg_scalar ( generic0 , generic1 , generic2 , generic3 , generic4 , generic5 , generic6 , generic7 , generic8 , generic9 , & & generica , genericb , genericc , genericd , generice , genericf , genericg , generich , generici , genericj , & & sep ) ! ident_14=\"@(#) M_CLI2 msg_scalar(3fp) writes a message to a string composed of any standard scalar types\" class ( * ), intent ( in ), optional :: generic0 , generic1 , generic2 , generic3 , generic4 class ( * ), intent ( in ), optional :: generic5 , generic6 , generic7 , generic8 , generic9 class ( * ), intent ( in ), optional :: generica , genericb , genericc , genericd , generice class ( * ), intent ( in ), optional :: genericf , genericg , generich , generici , genericj character ( len =* ), intent ( in ), optional :: sep character ( len = :), allocatable :: sep_local character ( len = :), allocatable :: msg_scalar character ( len = 4096 ) :: line integer :: istart integer :: increment if ( present ( sep )) then sep_local = sep increment = len ( sep_local ) + 1 else sep_local = ' ' increment = 2 endif istart = 1 line = '' if ( present ( generic0 )) call print_generic ( generic0 ) if ( present ( generic1 )) call print_generic ( generic1 ) if ( present ( generic2 )) call print_generic ( generic2 ) if ( present ( generic3 )) call print_generic ( generic3 ) if ( present ( generic4 )) call print_generic ( generic4 ) if ( present ( generic5 )) call print_generic ( generic5 ) if ( present ( generic6 )) call print_generic ( generic6 ) if ( present ( generic7 )) call print_generic ( generic7 ) if ( present ( generic8 )) call print_generic ( generic8 ) if ( present ( generic9 )) call print_generic ( generic9 ) if ( present ( generica )) call print_generic ( generica ) if ( present ( genericb )) call print_generic ( genericb ) if ( present ( genericc )) call print_generic ( genericc ) if ( present ( genericd )) call print_generic ( genericd ) if ( present ( generice )) call print_generic ( generice ) if ( present ( genericf )) call print_generic ( genericf ) if ( present ( genericg )) call print_generic ( genericg ) if ( present ( generich )) call print_generic ( generich ) if ( present ( generici )) call print_generic ( generici ) if ( present ( genericj )) call print_generic ( genericj ) msg_scalar = trim ( line ) contains !=================================================================================================================================== subroutine print_generic ( generic ) use , intrinsic :: iso_fortran_env , only : int8 , int16 , int32 , int64 , real32 , real64 , real128 class ( * ), intent ( in ) :: generic select type ( generic ) type is ( integer ( kind = int8 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int16 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int32 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int64 )); write ( line ( istart :), '(i0)' ) generic type is ( real ( kind = real32 )); write ( line ( istart :), '(1pg0)' ) generic type is ( real ( kind = real64 )) write ( line ( istart :), '(1pg0)' ) generic !x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic type is ( logical ) write ( line ( istart :), '(l1)' ) generic type is ( character ( len =* )) write ( line ( istart :), '(a)' ) trim ( generic ) type is ( complex ); write ( line ( istart :), '(\"(\",1pg0,\",\",1pg0,\")\")' ) generic end select istart = len_trim ( line ) + increment line = trim ( line ) // sep_local end subroutine print_generic !=================================================================================================================================== end function msg_scalar !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function msg_one ( generic0 , generic1 , generic2 , generic3 , generic4 , generic5 , generic6 , generic7 , generic8 , generic9 , sep ) ! ident_15=\"@(#) M_CLI2 msg_one(3fp) writes a message to a string composed of any standard one dimensional types\" class ( * ), intent ( in ) :: generic0 (:) class ( * ), intent ( in ), optional :: generic1 (:), generic2 (:), generic3 (:), generic4 (:), generic5 (:) class ( * ), intent ( in ), optional :: generic6 (:), generic7 (:), generic8 (:), generic9 (:) character ( len =* ), intent ( in ), optional :: sep character ( len = :), allocatable :: sep_local character ( len = :), allocatable :: msg_one character ( len = 4096 ) :: line integer :: istart integer :: increment if ( present ( sep )) then sep_local = sep increment = len ( sep_local ) + 1 else sep_local = ' ' increment = 2 endif istart = 1 line = ' ' call print_generic ( generic0 ) if ( present ( generic1 )) call print_generic ( generic1 ) if ( present ( generic2 )) call print_generic ( generic2 ) if ( present ( generic3 )) call print_generic ( generic3 ) if ( present ( generic4 )) call print_generic ( generic4 ) if ( present ( generic5 )) call print_generic ( generic5 ) if ( present ( generic6 )) call print_generic ( generic6 ) if ( present ( generic7 )) call print_generic ( generic7 ) if ( present ( generic8 )) call print_generic ( generic8 ) if ( present ( generic9 )) call print_generic ( generic9 ) msg_one = trim ( line ) contains !=================================================================================================================================== subroutine print_generic ( generic ) use , intrinsic :: iso_fortran_env , only : int8 , int16 , int32 , int64 , real32 , real64 , real128 class ( * ), intent ( in ), optional :: generic (:) integer :: i select type ( generic ) type is ( integer ( kind = int8 )); write ( line ( istart :), '(\"[\",*(i0,1x))' ) generic type is ( integer ( kind = int16 )); write ( line ( istart :), '(\"[\",*(i0,1x))' ) generic type is ( integer ( kind = int32 )); write ( line ( istart :), '(\"[\",*(i0,1x))' ) generic type is ( integer ( kind = int64 )); write ( line ( istart :), '(\"[\",*(i0,1x))' ) generic type is ( real ( kind = real32 )); write ( line ( istart :), '(\"[\",*(1pg0,1x))' ) generic type is ( real ( kind = real64 )); write ( line ( istart :), '(\"[\",*(1pg0,1x))' ) generic !x! DOES NOT WORK WITH nvfortran: type is (real(kind=real128)); write(line(istart:),'(\"[\",*(1pg0,1x))') generic !x! DOES NOT WORK WITH ifort: type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic type is ( logical ); write ( line ( istart :), '(\"[\",*(l1,1x))' ) generic type is ( character ( len =* )) write ( line ( istart :), '(\"[\",:*(\"\"\"\",a,\"\"\"\",1x))' ) ( trim ( generic ( i )), i = 1 , size ( generic )) type is ( complex ); write ( line ( istart :), '(\"[\",*(\"(\",1pg0,\",\",1pg0,\")\",1x))' ) generic class default call mystop ( - 22 , 'unknown type in *print_generic*' ) end select istart = len_trim ( line ) + increment + 1 line = trim ( line ) // \"]\" // sep_local end subroutine print_generic !=================================================================================================================================== end function msg_one !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function upper ( str ) result ( string ) ! ident_16=\"@(#) M_CLI2 upper(3f) Changes a string to uppercase\" character ( * ), intent ( in ) :: str character (:), allocatable :: string integer :: i string = str do i = 1 , len_trim ( str ) select case ( str ( i : i )) case ( 'a' : 'z' ) string ( i : i ) = char ( iachar ( str ( i : i )) - 32 ) end select end do end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function lower ( str ) result ( string ) ! ident_17=\"@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range\" character ( * ), intent ( In ) :: str character (:), allocatable :: string integer :: i string = str do i = 1 , len_trim ( str ) select case ( str ( i : i )) case ( 'A' : 'Z' ) string ( i : i ) = char ( iachar ( str ( i : i )) + 32 ) end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine a2i ( chars , valu , ierr ) ! ident_18=\"@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string\" character ( len =* ), intent ( in ) :: chars ! input string integer , intent ( out ) :: valu ! value read from input string integer , intent ( out ) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 integer , parameter :: ihuge = huge ( 0 ) valu8 = 0.0d0 call a2d ( chars , valu8 , ierr , onerr = 0.0d0 ) if ( valu8 <= huge ( valu )) then if ( valu8 <= huge ( valu )) then valu = int ( valu8 ) else call journal ( 'sc' , '*a2i*' , '- value too large' , valu8 , '>' , ihuge ) valu = huge ( valu ) ierr =- 1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d ( chars , valu , ierr , onerr ) ! ident_19=\"@(#) M_CLI2 a2d(3fp) subroutine returns double value from string\" ! 1989,2016 John S. Urban. ! ! o works with any g-format input, including integer, real, and exponential. ! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. ! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. ! IERR will still be non-zero in this case. !---------------------------------------------------------------------------------------------------------------------------------- character ( len =* ), intent ( in ) :: chars ! input string character ( len = :), allocatable :: local_chars doubleprecision , intent ( out ) :: valu ! value read from input string integer , intent ( out ) :: ierr ! error flag (0 == no error) class ( * ), optional , intent ( in ) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- character ( len =* ), parameter :: fmt = \"('(bn,g',i5,'.0)')\" ! format used to build frmt character ( len = 15 ) :: frmt ! holds format built to read input string character ( len = 256 ) :: msg ! hold message from I/O errors integer :: intg integer :: pnd integer :: basevalue , ivalu character ( len = 3 ), save :: nan_string = 'NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr = 0 ! initialize error flag to zero local_chars = unquote ( chars ) msg = '' if ( len ( local_chars ) == 0 ) local_chars = ' ' call substitute ( local_chars , ',' , '' ) ! remove any comma characters pnd = scan ( local_chars , '#:' ) if ( pnd /= 0 ) then write ( frmt , fmt ) pnd - 1 ! build format of form '(BN,Gn.0)' read ( local_chars (: pnd - 1 ), fmt = frmt , iostat = ierr , iomsg = msg ) basevalue ! try to read value from string if ( decodebase ( local_chars ( pnd + 1 :), basevalue , ivalu )) then valu = real ( ivalu , kind = kind ( 0.0d0 )) else valu = 0.0d0 ierr =- 1 endif else select case ( local_chars ( 1 : 1 )) case ( 'z' , 'Z' , 'h' , 'H' ) ! assume hexadecimal frmt = '(Z' // i2s ( len ( local_chars )) // ')' read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case ( 'b' , 'B' ) ! assume binary (base 2) frmt = '(B' // i2s ( len ( local_chars )) // ')' read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case ( 'o' , 'O' ) ! assume octal frmt = '(O' // i2s ( len ( local_chars )) // ')' read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case default write ( frmt , fmt ) len ( local_chars ) ! build format of form '(BN,Gn.0)' read ( local_chars , fmt = frmt , iostat = ierr , iomsg = msg ) valu ! try to read value from string end select endif if ( ierr /= 0 ) then ! if an error occurred ierr will be non-zero. if ( present ( onerr )) then select type ( onerr ) type is ( integer ) valu = onerr type is ( real ) valu = onerr type is ( doubleprecision ) valu = onerr end select else ! set return value to NaN read ( nan_string , '(f3.3)' ) valu endif if ( local_chars /= 'eod' ) then ! print warning message except for special value \"eod\" call journal ( 'sc' , '*a2d* - cannot produce number from string [' // trim ( chars ) // ']' ) if ( msg /= '' ) then call journal ( 'sc' , '*a2d* - [' // trim ( msg ) // ']' ) endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified !! delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the \"whitespace\" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! !! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_CLI2, only: split !! character(len=*),parameter :: & !! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,'(80(\"=\"))') !! write(*,*)'typical call:' !! CALL split(line,array) !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)& !! &'custom list of delimiters, reverse array order and count null fields:' !! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,*)& !! &'default delimiters and reverse array order and return null fields:' !! CALL split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! end program demo_split !! !! Output !! !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > =========================================================================== !! > typical call: !! > 1 ==> aBcdef !! > 2 ==> ghijklmnop !! > 3 ==> qrstuvwxyz !! > 4 ==> 1:|:2 !! > 5 ==> 333|333 !! > 6 ==> a !! > 7 ==> B !! > 8 ==> cc !! > SIZE: 8 !! > -------------------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > 2 ==> 2 333 !! > 3 ==> 333 a B cc !! > SIZE: 3 !! > -------------------------------------------------------------------------- !! > custom list of delimiters, reverse array order and return null fields: !! > 1 ==> 333 a B cc !! > 2 ==> 2 333 !! > 3 ==> !! > 4 ==> !! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! > -------------------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! > 1 ==> !! > 2 ==> !! > 3 ==> !! > 4 ==> cc !! > 5 ==> B !! > 6 ==> a !! > 7 ==> 333|333 !! > 8 ==> !! > 9 ==> !! > 10 ==> !! > 11 ==> !! > 12 ==> 1:|:2 !! > 13 ==> !! > 14 ==> qrstuvwxyz !! > 15 ==> ghijklmnop !! > 16 ==> !! > 17 ==> !! > 18 ==> aBcdef !! > 19 ==> !! > 20 ==> !! > SIZE: 20 !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine split ( input_line , array , delimiters , order , nulls ) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_20=\"@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array\" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index , min , present , len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure \" par1 par2 par3 ... parn \" store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character ( len =* ), intent ( in ) :: input_line ! input string to tokenize character ( len =* ), optional , intent ( in ) :: delimiters ! list of delimiter characters character ( len =* ), optional , intent ( in ) :: order ! order of output array sequential|[reverse|right] character ( len =* ), optional , intent ( in ) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character ( len = :), allocatable , intent ( out ) :: array (:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer , allocatable :: ibegin (:) ! positions in input string where tokens start integer , allocatable :: iterm (:) ! positions in input string where tokens end character ( len = :), allocatable :: dlim ! string containing delimiter characters character ( len = :), allocatable :: ordr ! string containing order keyword character ( len = :), allocatable :: nlls ! string containing nulls keyword integer :: ii , iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: iilen ! length of input string with trailing spaces trimmed integer :: i10 , i20 , i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if ( present ( delimiters )) then ! optional delimiter list was present if ( delimiters /= '' ) then ! if DELIMITERS was specified and not null use it dlim = delimiters else ! DELIMITERS was specified on call as empty string dlim = ' ' // char ( 9 ) // char ( 10 ) // char ( 11 ) // char ( 12 ) // char ( 13 ) // char ( 0 ) // ',:' ! use default delimiter when not specified endif else ! no delimiter value was specified dlim = ' ' // char ( 9 ) // char ( 10 ) // char ( 11 ) // char ( 12 ) // char ( 13 ) // char ( 0 ) // ',:' ! use default delimiter when not specified endif idlim = len ( dlim ) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( order )) then ; ordr = lower ( adjustl ( order )); else ; ordr = 'sequential' ; endif ! decide on value for optional ORDER parameter if ( present ( nulls )) then ; nlls = lower ( adjustl ( nulls )); else ; nlls = 'ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n = len ( input_line ) + 1 ! max number of strings INPUT_LINE could split into if all delimiter if ( allocated ( ibegin )) deallocate ( ibegin ) !x! intel compiler says allocated already ??? allocate ( ibegin ( n )) ! allocate enough space to hold starting location of tokens if string all tokens if ( allocated ( iterm )) deallocate ( iterm ) !x! intel compiler says allocated already ??? allocate ( iterm ( n )) ! allocate enough space to hold ending location of tokens if string all tokens ibegin (:) = 1 iterm (:) = 1 !----------------------------------------------------------------------------------------------------------------------------------- iilen = len ( input_line ) ! IILEN is the column position of the last non-blank character icount = 0 ! how many tokens found inotnull = 0 ! how many tokens found not composed of delimiters imax = 0 ! length of longest token found if ( iilen > 0 ) then ! there is at least one non-delimiter in INPUT_LINE if get here icol = 1 ! initialize pointer into input line INFINITE : do i30 = 1 , iilen , 1 ! store into each array element ibegin ( i30 ) = icol ! assume start new token on the character if ( index ( dlim ( 1 : idlim ), input_line ( icol : icol )) == 0 ) then ! if current character is not a delimiter iterm ( i30 ) = iilen ! initially assume no more tokens do i10 = 1 , idlim ! search for next delimiter ifound = index ( input_line ( ibegin ( i30 ): iilen ), dlim ( i10 : i10 )) IF ( ifound > 0 ) then iterm ( i30 ) = min ( iterm ( i30 ), ifound + ibegin ( i30 ) - 2 ) endif enddo icol = iterm ( i30 ) + 2 ! next place to look as found end of this token inotnull = inotnull + 1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm ( i30 ) = icol - 1 ! record assumed end of string. Will be less than beginning icol = icol + 1 ! advance pointer into input string endif imax = max ( imax , iterm ( i30 ) - ibegin ( i30 ) + 1 ) icount = i30 ! increment count of number of tokens found if ( icol > iilen ) then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case ( trim ( adjustl ( nlls ))) case ( 'ignore' , '' , 'ignoreend' ) ireturn = inotnull case default ireturn = icount end select if ( allocated ( array )) deallocate ( array ) allocate ( character ( len = imax ) :: array ( ireturn )) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn !----------------------------------------------------------------------------------------------------------------------------------- select case ( trim ( adjustl ( ordr ))) ! decide which order to store tokens case ( 'reverse' , 'right' ) ; ii = ireturn ; iiii =- 1 ! last to first case default ; ii = 1 ; iiii = 1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20 = 1 , icount ! fill the array with the tokens that were found if ( iterm ( i20 ) < ibegin ( i20 )) then select case ( trim ( adjustl ( nlls ))) case ( 'ignore' , '' , 'ignoreend' ) case default array ( ii ) = ' ' ii = ii + iiii end select else array ( ii ) = input_line ( ibegin ( i20 ): iterm ( i20 )) ii = ii + iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function replace_str(targetline[,old,new|cmd],range,ierr) result (newline) !! !! character(len=*) :: targetline !! character(len=*),intent(in),optional :: old !! character(len=*),intent(in),optional :: new !! character(len=*),intent(in),optional :: cmd !! integer,intent(in),optional :: range(2) !! integer,intent(out),optional :: ierr !! logical,intent(in),optional :: clip !! character(len=:),allocatable :: newline !!##DESCRIPTION !! Globally replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! cmd alternate way to specify old and new string, in !! the form c/old/new/; where \"/\" can be any character !! not in \"old\" or \"new\" !! range if present, only change range(1) to range(2) of !! occurrences of old string !! ierr error code. If ier = -1 bad directive, >= 0 then !! count of changes made !! clip whether to return trailing spaces or not. Defaults to .false. !!##RETURNS !! newline allocatable string returned !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace_str !! use M_CLI2, only : replace_str !! implicit none !! character(len=:),allocatable :: targetline !! !! targetline='this is the input string' !! !! call testit('th','TH','THis is THe input string') !! !! ! a null old substring means \"at beginning of line\" !! call testit('','BEFORE:', 'BEFORE:THis is THe input string') !! !! ! a null new string deletes occurrences of the old substring !! call testit('i','', 'BEFORE:THs s THe nput strng') !! !! write(*,*)'Examples of the use of RANGE=' !! !! targetline=replace_str('a b ab baaa aaaa','a','A') !! write(*,*)'replace a with A ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) !! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) !! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',range=[3,5]) !! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' !! !! contains !! subroutine testit(old,new,expected) !! character(len=*),intent(in) :: old,new,expected !! write(*,*)repeat('=',79) !! write(*,*)':STARTED ['//targetline//']' !! write(*,*)':OLD['//old//']', ' NEW['//new//']' !! targetline=replace_str(targetline,old,new) !! write(*,*)':GOT ['//targetline//']' !! write(*,*)':EXPECTED['//expected//']' !! write(*,*)':TEST [',targetline == expected,']' !! end subroutine testit !! !! end program demo_replace_str !! !! Expected output !! !! =============================================================================== !! STARTED [this is the input string] !! OLD[th] NEW[TH] !! GOT [THis is THe input string] !! EXPECTED[THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [THis is THe input string] !! OLD[] NEW[BEFORE:] !! GOT [BEFORE:THis is THe input string] !! EXPECTED[BEFORE:THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [BEFORE:THis is THe input string] !! OLD[i] NEW[] !! GOT [BEFORE:THs s THe nput strng] !! EXPECTED[BEFORE:THs s THe nput strng] !! TEST [ T ] !! Examples of the use of RANGE= !! replace a with A [A b Ab bAAA AAAA] !! replace a with A instances 3 to 5 [a b ab bAAA aaaa] !! replace a with null instances 3 to 5 [a b ab b aaaa] !! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC !! a a a aa aaaaaa] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine crack_cmd ( cmd , old , new , ierr ) !----------------------------------------------------------------------------------------------------------------------------------- character ( len =* ), intent ( in ) :: cmd character ( len = :), allocatable , intent ( out ) :: old , new ! scratch string buffers integer :: ierr !----------------------------------------------------------------------------------------------------------------------------------- character ( len = 1 ) :: delimiters integer :: itoken integer , parameter :: id = 2 ! expected location of delimiter logical :: ifok integer :: lmax ! length of target string integer :: start_token , end_token !----------------------------------------------------------------------------------------------------------------------------------- ierr = 0 old = '' new = '' lmax = len_trim ( cmd ) ! significant length of change directive if ( lmax >= 4 ) then ! strtok ignores blank tokens so look for special case where first token is really null delimiters = cmd ( id : id ) ! find delimiter in expected location itoken = 0 ! initialize strtok(3f) procedure if ( strtok ( cmd ( id :), itoken , start_token , end_token , delimiters )) then ! find OLD string old = cmd ( start_token + id - 1 : end_token + id - 1 ) else old = '' endif if ( cmd ( id : id ) == cmd ( id + 1 : id + 1 )) then new = old old = '' else ! normal case ifok = strtok ( cmd ( id :), itoken , start_token , end_token , delimiters ) ! find NEW string if ( end_token == ( len ( cmd ) - id + 1 ) ) end_token = len_trim ( cmd ( id :)) ! if missing ending delimiter new = cmd ( start_token + id - 1 : min ( end_token + id - 1 , lmax )) endif else ! command was two or less characters ierr =- 1 call journal ( 'sc' , '*crack_cmd* incorrect change directive -too short' ) endif end subroutine crack_cmd !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function replace_str ( targetline , old , new , ierr , cmd , range ) result ( newline ) ! ident_21=\"@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string\" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character ( len =* ), intent ( in ) :: targetline ! input line to be changed character ( len =* ), intent ( in ), optional :: old ! old substring to replace character ( len =* ), intent ( in ), optional :: new ! new substring integer , intent ( out ), optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made character ( len =* ), intent ( in ), optional :: cmd ! contains the instructions changing the string integer , intent ( in ), optional :: range ( 2 ) ! start and end of which changes to make !----------------------------------------------------------------------------------------------------------------------------------- ! returns character ( len = :), allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local character ( len = :), allocatable :: new_local , old_local integer :: icount , ichange , ier2 integer :: original_input_length integer :: len_old , len_new integer :: ladd integer :: left_margin , right_margin integer :: ind integer :: ic integer :: iichar integer :: range_local ( 2 ) !----------------------------------------------------------------------------------------------------------------------------------- ! get old_local and new_local from cmd or old and new if ( present ( cmd )) then call crack_cmd ( cmd , old_local , new_local , ier2 ) if ( ier2 /= 0 ) then newline = targetline ! if no changes are made return original string on error if ( present ( ierr )) ierr = ier2 return endif elseif ( present ( old ). and . present ( new )) then old_local = old new_local = new else newline = targetline ! if no changes are made return original string on error call journal ( 'sc' , '*replace_str* must specify OLD and NEW or CMD' ) return endif !----------------------------------------------------------------------------------------------------------------------------------- icount = 0 ! initialize error flag/change count ichange = 0 ! initialize error flag/change count original_input_length = len_trim ( targetline ) ! get non-blank length of input line len_old = len ( old_local ) ! length of old substring to be replaced len_new = len ( new_local ) ! length of new substring to replace old substring left_margin = 1 ! left_margin is left margin of window to change right_margin = len ( targetline ) ! right_margin is right margin of window to change newline = '' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( range )) then range_local = range else range_local = [ 1 , original_input_length ] endif !----------------------------------------------------------------------------------------------------------------------------------- if ( len_old == 0 ) then ! c//new/ means insert new at beginning of line (or left margin) iichar = len_new + original_input_length if ( len_new > 0 ) then newline = new_local (: len_new ) // targetline ( left_margin : original_input_length ) else newline = targetline ( left_margin : original_input_length ) endif ichange = 1 ! made one change. actually, c/// should maybe return 0 if ( present ( ierr )) ierr = ichange return endif !----------------------------------------------------------------------------------------------------------------------------------- iichar = left_margin ! place to put characters into output string ic = left_margin ! place looking at in input string loop : do ind = index ( targetline ( ic :), old_local (: len_old )) + ic - 1 ! try finding start of OLD in remaining part of input in change window if ( ind == ic - 1. or . ind > right_margin ) then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount = icount + 1 ! found an old string to change, so increment count of change candidates if ( ind > ic ) then ! if found old string past at current position in input string copy unchanged ladd = ind - ic ! find length of character range to copy as-is from input to output newline = newline (: iichar - 1 ) // targetline ( ic : ind - 1 ) iichar = iichar + ladd endif if ( icount >= range_local ( 1 ). and . icount <= range_local ( 2 )) then ! check if this is an instance to change or keep ichange = ichange + 1 if ( len_new /= 0 ) then ! put in new string newline = newline (: iichar - 1 ) // new_local (: len_new ) iichar = iichar + len_new endif else if ( len_old /= 0 ) then ! put in copy of old string newline = newline (: iichar - 1 ) // old_local (: len_old ) iichar = iichar + len_old endif endif ic = ind + len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case ( ichange ) case ( 0 ) ! there were no changes made to the window newline = targetline ! if no changes made output should be input case default if ( ic <= len ( targetline )) then ! if there is more after last change on original line add it newline = newline (: iichar - 1 ) // targetline ( ic : max ( ic , original_input_length )) endif end select if ( present ( ierr )) ierr = ichange !----------------------------------------------------------------------------------------------------------------------------------- end function replace_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with !! list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead !! of double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP !! is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_CLI2, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function quote ( str , mode , clip ) result ( quoted_str ) character ( len =* ), intent ( in ) :: str ! the string to be quoted character ( len =* ), optional , intent ( in ) :: mode logical , optional , intent ( in ) :: clip logical :: clip_local character ( len = :), allocatable :: quoted_str character ( len = 1 ), parameter :: double_quote = '\"' character ( len = 20 ) :: local_mode !----------------------------------------------------------------------------------------------------------------------------------- local_mode = merge_str ( mode , 'DOUBLE' , present ( mode )) if ( present ( clip )) then clip_local = clip else clip_local = . false . endif if ( clip_local ) then quoted_str = adjustl ( str ) else quoted_str = str endif select case ( lower ( local_mode )) case ( 'double' ) quoted_str = double_quote // trim ( replace_str ( quoted_str , '\"' , '\"\"' )) // double_quote case ( 'escape' ) quoted_str = double_quote // trim ( replace_str ( quoted_str , '\"' , '\\\"' )) // double_quote case default call journal ( 'sc' , '*quote* ERROR: unknown quote mode ' , local_mode ) quoted_str = str end select !----------------------------------------------------------------------------------------------------------------------------------- end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read !! with list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! pure function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_CLI2, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain pure function unquote ( quoted_str , esc ) result ( unquoted_str ) character ( len =* ), intent ( in ) :: quoted_str ! the string to be unquoted character ( len = 1 ), optional , intent ( in ) :: esc ! escape character character ( len = :), allocatable :: unquoted_str integer :: inlen character ( len = 1 ), parameter :: single_quote = \"'\" character ( len = 1 ), parameter :: double_quote = '\"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( esc )) then ! select escape character as specified character or special value meaning not set iesc = ichar ( esc ) ! allow for an escape character else iesc =- 1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen = len ( quoted_str ) ! find length of input string if ( allocated ( unquoted_str )) deallocate ( unquoted_str ) allocate ( character ( len = inlen ) :: unquoted_str ) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if ( inlen >= 1 ) then ! double_quote is the default quote unless the first character is single_quote if ( quoted_str ( 1 : 1 ) == single_quote ) then quote = ichar ( single_quote ) else quote = ichar ( double_quote ) endif else quote = ichar ( double_quote ) endif !----------------------------------------------------------------------------------------------------------------------------------- before =- 2 ! initially set previous character to impossible value unquoted_str (:) = '' ! initialize output string to null string iput = 1 inside = . false . STEPTHROUGH : do i = 1 , inlen current = ichar ( quoted_str ( i : i )) if ( before == iesc ) then ! if previous character was escape use current character unconditionally iput = iput - 1 ! backup unquoted_str ( iput : iput ) = char ( current ) iput = iput + 1 before =- 2 ! this could be second esc or quote elseif ( current == quote ) then ! if current is a quote it depends on whether previous character was a quote if ( before == quote ) then unquoted_str ( iput : iput ) = char ( quote ) ! this is second quote so retain it iput = iput + 1 before =- 2 elseif (. not . inside . and . before /= iesc ) then inside = . true . else ! this is first quote so ignore it except remember it in case next is a quote before = current endif else unquoted_str ( iput : iput ) = char ( current ) iput = iput + 1 before = current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str = unquoted_str (: iput - 1 ) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function i2s ( ivalue , fmt ) result ( outstr ) ! ident_22=\"@(#) M_CLI2 i2s(3fp) private function returns string given integer value\" integer , intent ( in ) :: ivalue ! input value to convert to a string character ( len =* ), intent ( in ), optional :: fmt character ( len = :), allocatable :: outstr ! output string to generate character ( len = 80 ) :: string if ( present ( fmt )) then call value_to_string ( ivalue , string , fmt = fmt ) else call value_to_string ( ivalue , string ) endif outstr = trim ( string ) end function i2s !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! merge_str(3f) - [M_CLI2:LENGTH] pads strings to same length and then !! calls MERGE(3f) !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function merge_str(str1,str2,expr) result(strout) !! !! character(len=*),intent(in),optional :: str1 !! character(len=*),intent(in),optional :: str2 !! logical,intent(in) :: expr !! character(len=:),allocatable :: strout !!##DESCRIPTION !! merge_str(3f) pads the shorter of str1 and str2 to the longest length !! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr). !! It trims trailing spaces off the result and returns the trimmed !! string. This makes it easier to call MERGE(3f) with strings, as !! MERGE(3f) requires the strings to be the same length. !! !! NOTE: STR1 and STR2 are always required even though declared optional. !! this is so the call \"STR_MERGE(A,B,present(A))\" is a valid call. !! The parameters STR1 and STR2 when they are optional parameters !! can be passed to a procedure if the options are optional on the !! called procedure. !! !!##OPTIONS !! STR1 string to return if the logical expression EXPR is true !! STR2 string to return if the logical expression EXPR is false !! EXPR logical expression to evaluate to determine whether to return !! STR1 when true, and STR2 when false. !!##RESULT !! MERGE_STR a trimmed string is returned that is otherwise the value !! of STR1 or STR2, depending on the logical expression EXPR. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_merge_str !! use M_CLI2, only : merge_str !! implicit none !! character(len=:), allocatable :: answer !! answer=merge_str('first string', 'second string is longer',10 == 10) !! write(*,'(\"[\",a,\"]\")') answer !! answer=merge_str('first string', 'second string is longer',10 /= 10) !! write(*,'(\"[\",a,\"]\")') answer !! end program demo_merge_str !! !! Expected output !! !! [first string] !! [second string is longer] !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function merge_str ( str1 , str2 , expr ) result ( strout ) ! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length ! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces ! ident_23=\"@(#) M_CLI2 merge_str(3f) pads first and second arguments to MERGE(3f) to same length\" character ( len =* ), intent ( in ), optional :: str1 character ( len =* ), intent ( in ), optional :: str2 character ( len = :), allocatable :: str1_local character ( len = :), allocatable :: str2_local logical , intent ( in ) :: expr character ( len = :), allocatable :: strout integer :: big if ( present ( str2 )) then str2_local = str2 else str2_local = '' endif if ( present ( str1 )) then str1_local = str1 else str1_local = '' endif big = max ( len ( str1_local ), len ( str2_local ) ) ! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning '' strout = trim ( merge ( lenset ( str1_local , big ), lenset ( str2_local , big ), expr )) end function merge_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_CLI2, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'(\"Start Base (2 to 36): \")',advance='no'); read *, bd !! write(*,'(\"Arrival Base (2 to 36): \")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'(\"Enter number in start base: \")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'(\"In base \",I2,\": \",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: \"Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988\". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase ( string , basein , out_baseten ) ! ident_24=\"@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number\" character ( len =* ), intent ( in ) :: string integer , intent ( in ) :: basein integer , intent ( out ) :: out_baseten character ( len = len ( string )) :: string_local integer :: long , i , j , k real :: y real :: mult character ( len = 1 ) :: ch real , parameter :: XMAXREAL = real ( huge ( 1 )) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local = upper ( trim ( adjustl ( string ))) decodebase = . false . ipound = index ( string_local , '#' ) ! determine if in form [-]base#whole if ( basein == 0. and . ipound > 1 ) then ! split string into two values call a2i ( string_local (: ipound - 1 ), basein_local , ierr ) ! get the decimal value of the base string_local = string_local ( ipound + 1 :) ! now that base is known make string just the value if ( basein_local >= 0 ) then ! allow for a negative sign prefix out_sign = 1 else out_sign =- 1 endif basein_local = abs ( basein_local ) else ! assume string is a simple positive value basein_local = abs ( basein ) out_sign = 1 endif out_baseten = 0 y = 0.0 ALL : if ( basein_local < 2. or . basein_local > 36 ) then print * , '(*decodebase* ERROR: Base must be between 2 and 36. base=' , basein_local else ALL out_baseten = 0 ; y = 0.0 ; mult = 1.0 long = LEN_TRIM ( string_local ) do i = 1 , long k = long + 1 - i ch = string_local ( k : k ) IF ( CH == '-' . AND . K == 1 ) THEN out_sign =- 1 cycle endif if ( ch < '0' . or . ch > 'Z' . or .( ch > '9' . and . ch < 'A' )) then write ( * , * ) '*decodebase* ERROR: invalid character ' , ch exit ALL endif if ( ch <= '9' ) then j = IACHAR ( ch ) - IACHAR ( '0' ) else j = IACHAR ( ch ) - IACHAR ( 'A' ) + 10 endif if ( j >= basein_local ) then exit ALL endif y = y + mult * j if ( mult > XMAXREAL / basein_local ) then exit ALL endif mult = mult * basein_local enddo decodebase = . true . out_baseten = nint ( out_sign * y ) * sign ( 1 , basein ) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! lenset(3f) - [M_CLI2:LENGTH] return string trimmed or padded to !! specified length !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function lenset(str,length) result(strout) !! !! character(len=*) :: str !! character(len=length) :: strout !! integer,intent(in) :: length !!##DESCRIPTION !! lenset(3f) truncates a string or pads it with spaces to the specified !! length. !!##OPTIONS !! str input string !! length output string length !!##RESULTS !! strout output string !!##EXAMPLE !! !! Sample Program: !! !! program demo_lenset !! use M_CLI2, only : lenset !! implicit none !! character(len=10) :: string='abcdefghij' !! character(len=:),allocatable :: answer !! answer=lenset(string,5) !! write(*,'(\"[\",a,\"]\")') answer !! answer=lenset(string,20) !! write(*,'(\"[\",a,\"]\")') answer !! end program demo_lenset !! !! Expected output: !! !! [abcde] !! [abcdefghij ] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function lenset ( line , length ) result ( strout ) ! ident_25=\"@(#) M_CLI2 lenset(3f) return string trimmed or padded to specified length\" character ( len =* ), intent ( in ) :: line integer , intent ( in ) :: length character ( len = length ) :: strout strout = line end function lenset !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! value_to_string(3f) - [M_CLI2:NUMERIC] return numeric string from !! a numeric value !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine value_to_string(value,chars[,iilen,ierr,fmt,trimz]) !! !! character(len=*) :: chars ! minimum of 23 characters required !! !-------- !! ! VALUE may be any one of the following types: !! doubleprecision,intent(in) :: value !! real,intent(in) :: value !! integer,intent(in) :: value !! logical,intent(in) :: value !! !-------- !! character(len=*),intent(out) :: chars !! integer,intent(out),optional :: iilen !! integer,optional :: ierr !! character(len=*),intent(in),optional :: fmt !! logical,intent(in) :: trimz !! !!##DESCRIPTION !! value_to_string(3f) returns a numeric representation of a numeric !! value in a string given a numeric value of type REAL, DOUBLEPRECISION, !! INTEGER or LOGICAL. It creates the string using internal writes. It !! then removes trailing zeros from non-zero values, and left-justifies !! the string. !! !!##OPTIONS !! VALUE input value to be converted to a string !! FMT You may specify a specific format that produces a string !! up to the length of CHARS; optional. !! TRIMZ If a format is supplied the default is not to try to trim !! trailing zeros. Set TRIMZ to .true. to trim zeros from a !! string assumed to represent a simple numeric value. !! !!##RETURNS !! CHARS returned string representing input value, must be at least !! 23 characters long; or what is required by optional FMT !! if longer. !! IILEN position of last non-blank character in returned string; !! optional. !! IERR If not zero, error occurred; optional. !!##EXAMPLE !! !! Sample program: !! !! program demo_value_to_string !! use M_CLI2, only: value_to_string !! implicit none !! character(len=80) :: string !! integer :: iilen !! call value_to_string(3.0/4.0,string,iilen) !! write(*,*) 'The value is [',string(:iilen),']' !! !! call value_to_string(3.0/4.0,string,iilen,fmt='') !! write(*,*) 'The value is [',string(:iilen),']' !! !! call value_to_string(3.0/4.0,string,iilen,fmt='(\"THE VALUE IS \",g0)') !! write(*,*) 'The value is [',string(:iilen),']' !! !! call value_to_string(1234,string,iilen) !! write(*,*) 'The value is [',string(:iilen),']' !! !! call value_to_string(1.0d0/3.0d0,string,iilen) !! write(*,*) 'The value is [',string(:iilen),']' !! !! end program demo_value_to_string !! !! Expected output !! !! The value is [0.75] !! The value is [ 0.7500000000] !! The value is [THE VALUE IS .750000000] !! The value is [1234] !! The value is [0.33333333333333331] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine value_to_string ( gval , chars , length , err , fmt , trimz ) ! ident_26=\"@(#) M_CLI2 value_to_string(3fp) subroutine returns a string from a value\" class ( * ), intent ( in ) :: gval character ( len =* ), intent ( out ) :: chars integer , intent ( out ), optional :: length integer , optional :: err integer :: err_local character ( len =* ), optional , intent ( in ) :: fmt ! format to write value with logical , intent ( in ), optional :: trimz character ( len = :), allocatable :: fmt_local character ( len = 1024 ) :: msg ! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL) if ( present ( fmt )) then select type ( gval ) type is ( integer ) fmt_local = '(i0)' if ( fmt /= '' ) fmt_local = fmt write ( chars , fmt_local , iostat = err_local , iomsg = msg ) gval type is ( real ) fmt_local = '(bz,g23.10e3)' fmt_local = '(bz,g0.8)' if ( fmt /= '' ) fmt_local = fmt write ( chars , fmt_local , iostat = err_local , iomsg = msg ) gval type is ( doubleprecision ) fmt_local = '(bz,g0)' if ( fmt /= '' ) fmt_local = fmt write ( chars , fmt_local , iostat = err_local , iomsg = msg ) gval type is ( logical ) fmt_local = '(l1)' if ( fmt /= '' ) fmt_local = fmt write ( chars , fmt_local , iostat = err_local , iomsg = msg ) gval class default call journal ( 'sc' , '*value_to_string* UNKNOWN TYPE' ) chars = ' ' end select if ( fmt == '' ) then chars = adjustl ( chars ) call trimzeros_ ( chars ) endif else ! no explicit format option present err_local =- 1 select type ( gval ) type is ( integer ) write ( chars , * , iostat = err_local , iomsg = msg ) gval type is ( real ) write ( chars , * , iostat = err_local , iomsg = msg ) gval type is ( doubleprecision ) write ( chars , * , iostat = err_local , iomsg = msg ) gval type is ( logical ) write ( chars , * , iostat = err_local , iomsg = msg ) gval class default chars = '' end select chars = adjustl ( chars ) if ( index ( chars , '.' ) /= 0 ) call trimzeros_ ( chars ) endif if ( present ( trimz )) then if ( trimz ) then chars = adjustl ( chars ) call trimzeros_ ( chars ) endif endif if ( present ( length )) then length = len_trim ( chars ) endif if ( present ( err )) then err = err_local elseif ( err_local /= 0 ) then !-! cannot currently do I/O from a function being called from I/O !-!write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']' chars = chars // ' *value_to_string* WARNING:[' // trim ( msg ) // ']' endif end subroutine value_to_string !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! trimzeros_(3fp) - [M_CLI2:NUMERIC] Delete trailing zeros from numeric !! `decimal string !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine trimzeros_(str) !! !! character(len=*) :: str !!##DESCRIPTION !! TRIMZEROS_(3f) deletes trailing zeros from a string representing a !! number. If the resulting string would end in a decimal point, one !! trailing zero is added. !!##OPTIONS !! str input string will be assumed to be a numeric value and have !! trailing zeros removed !!##EXAMPLES !! !! Sample program: !! !! program demo_trimzeros_ !! use M_CLI2, only : trimzeros_ !! character(len=:),allocatable :: string !! write(*,*)trimzeros_('123.450000000000') !! write(*,*)trimzeros_('12345') !! write(*,*)trimzeros_('12345.') !! write(*,*)trimzeros_('12345.00e3') !! end program demo_trimzeros_ !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine trimzeros_ ( string ) ! ident_27=\"@(#) M_CLI2 trimzeros_(3fp) Delete trailing zeros from numeric decimal string\" ! if zero needs added at end assumes input string has room character ( len =* ) :: string character ( len = len ( string ) + 2 ) :: str character ( len = len ( string )) :: expo ! the exponent string if present integer :: ipos ! where exponent letter appears if present integer :: i , ii str = string ! working copy of string ipos = scan ( str , 'eEdD' ) ! find end of real number if string uses exponent notation if ( ipos > 0 ) then ! letter was found expo = str ( ipos :) ! keep exponent string so it can be added back as a suffix str = str ( 1 : ipos - 1 ) ! just the real part, exponent removed will not have trailing zeros removed endif if ( index ( str , '.' ) == 0 ) then ! if no decimal character in original string add one to end of string ii = len_trim ( str ) str ( ii + 1 : ii + 1 ) = '.' ! add decimal to end of string endif do i = len_trim ( str ), 1 , - 1 ! scanning from end find a non-zero character select case ( str ( i : i )) case ( '0' ) ! found a trailing zero so keep trimming cycle case ( '.' ) ! found a decimal character at end of remaining string if ( i <= 1 ) then str = '0' else str = str ( 1 : i - 1 ) endif exit case default str = str ( 1 : i ) ! found a non-zero character so trim string and exit exit end select end do if ( ipos > 0 ) then ! if originally had an exponent place it back on string = trim ( str ) // trim ( expo ) else string = str endif end subroutine trimzeros_ !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! substitute(3f) - [M_CLI2:EDITING] subroutine globally substitutes !! one substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine substitute(targetline,old,new,ierr,start,end) !! !! character(len=*) :: targetline !! character(len=*),intent(in) :: old !! character(len=*),intent(in) :: new !! integer,intent(out),optional :: ierr !! integer,intent(in),optional :: start !! integer,intent(in),optional :: end !!##DESCRIPTION !! Globally substitute one substring for another in string. !! !!##OPTIONS !! TARGETLINE input line to be changed. Must be long enough to !! hold altered output. !! OLD substring to find and replace !! NEW replacement for OLD substring !! IERR error code. If IER = -1 bad directive, >= 0 then !! count of changes made. !! START sets the left margin to be scanned for OLD in !! TARGETLINE. !! END sets the right margin to be scanned for OLD in !! TARGETLINE. !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_substitute !! use M_CLI2, only : substitute !! implicit none !! ! must be long enough to hold changed line !! character(len=80) :: targetline !! !! targetline='this is the input string' !! write(*,*)'ORIGINAL : '//trim(targetline) !! !! ! changes the input to 'THis is THe input string' !! call substitute(targetline,'th','TH') !! write(*,*)'th => TH : '//trim(targetline) !! !! ! a null old substring means \"at beginning of line\" !! ! changes the input to 'BEFORE:this is the input string' !! call substitute(targetline,'','BEFORE:') !! write(*,*)'\"\" => BEFORE: '//trim(targetline) !! !! ! a null new string deletes occurrences of the old substring !! ! changes the input to 'ths s the nput strng' !! call substitute(targetline,'i','') !! write(*,*)'i => \"\" : '//trim(targetline) !! !! end program demo_substitute !! !! Expected output !! !! ORIGINAL : this is the input string !! th => TH : THis is THe input string !! \"\" => BEFORE: BEFORE:THis is THe input string !! i => \"\" : BEFORE:THs s THe nput strng !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine substitute ( targetline , old , new , ierr , start , end ) ! ident_28=\"@(#) M_CLI2 substitute(3f) Globally substitute one substring for another in string\" !----------------------------------------------------------------------------------------------------------------------------------- character ( len =* ) :: targetline ! input line to be changed character ( len =* ), intent ( in ) :: old ! old substring to replace character ( len =* ), intent ( in ) :: new ! new substring integer , intent ( out ), optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made integer , intent ( in ), optional :: start ! start sets the left margin integer , intent ( in ), optional :: end ! end sets the right margin !----------------------------------------------------------------------------------------------------------------------------------- character ( len = len ( targetline )) :: dum1 ! scratch string buffers integer :: ml , mr , ier1 integer :: maxlengthout ! MAXIMUM LENGTH ALLOWED FOR NEW STRING integer :: original_input_length integer :: len_old , len_new integer :: ladd integer :: ir integer :: ind integer :: il integer :: id integer :: ic integer :: iichar !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( start )) then ! optional starting column ml = start else ml = 1 endif if ( present ( end )) then ! optional ending column mr = end else mr = len ( targetline ) endif !----------------------------------------------------------------------------------------------------------------------------------- ier1 = 0 ! initialize error flag/change count maxlengthout = len ( targetline ) ! max length of output string original_input_length = len_trim ( targetline ) ! get non-blank length of input line dum1 (:) = ' ' ! initialize string to build output in id = mr - ml ! check for window option !-! change to optional parameter(s) !----------------------------------------------------------------------------------------------------------------------------------- len_old = len ( old ) ! length of old substring to be replaced len_new = len ( new ) ! length of new substring to replace old substring if ( id <= 0 ) then ! no window so change entire input string il = 1 ! il is left margin of window to change ir = maxlengthout ! ir is right margin of window to change dum1 (:) = ' ' ! begin with a blank line else ! if window is set il = ml ! use left margin ir = min0 ( mr , maxlengthout ) ! use right margin or rightmost dum1 = targetline (: il - 1 ) ! begin with what's below margin endif ! end of window settings !----------------------------------------------------------------------------------------------------------------------------------- if ( len_old == 0 ) then ! c//new/ means insert new at beginning of line (or left margin) iichar = len_new + original_input_length if ( iichar > maxlengthout ) then call journal ( 'sc' , '*substitute* new line will be too long' ) ier1 =- 1 if ( present ( ierr )) ierr = ier1 return endif if ( len_new > 0 ) then dum1 ( il :) = new (: len_new ) // targetline ( il : original_input_length ) else dum1 ( il :) = targetline ( il : original_input_length ) endif targetline ( 1 : maxlengthout ) = dum1 (: maxlengthout ) ier1 = 1 ! made one change. actually, c/// should maybe return 0 if ( present ( ierr )) ierr = ier1 return endif !----------------------------------------------------------------------------------------------------------------------------------- iichar = il ! place to put characters into output string ic = il ! place looking at in input string loop : do ind = index ( targetline ( ic :), old (: len_old )) + ic - 1 ! try to find start of old string in remaining part of input in change window if ( ind == ic - 1. or . ind > ir ) then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif ier1 = ier1 + 1 ! found an old string to change, so increment count of changes if ( ind > ic ) then ! if found old string past at current position in input string copy unchanged ladd = ind - ic ! find length of character range to copy as-is from input to output if ( iichar - 1 + ladd > maxlengthout ) then ier1 =- 1 exit loop endif dum1 ( iichar :) = targetline ( ic : ind - 1 ) iichar = iichar + ladd endif if ( iichar - 1 + len_new > maxlengthout ) then ier1 =- 2 exit loop endif if ( len_new /= 0 ) then dum1 ( iichar :) = new (: len_new ) iichar = iichar + len_new endif ic = ind + len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case ( ier1 ) case (: - 1 ) call journal ( 'sc' , '*substitute* new line will be too long' ) case ( 0 ) ! there were no changes made to the window case default ladd = original_input_length - ic if ( iichar + ladd > maxlengthout ) then call journal ( 'sc' , '*substitute* new line will be too long' ) ier1 =- 1 if ( present ( ierr )) ierr = ier1 return endif if ( ic < len ( targetline )) then dum1 ( iichar :) = targetline ( ic : max ( ic , original_input_length )) endif targetline = dum1 (: maxlengthout ) end select if ( present ( ierr )) ierr = ier1 !----------------------------------------------------------------------------------------------------------------------------------- end subroutine substitute !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! locate_(3f) - [M_CLI2] finds the index where a string is found or !! should be in a sorted array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine locate_(list,value,place,ier,errmsg) !! !! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! integer, intent(out) :: PLACE !! !! integer, intent(out),optional :: IER !! character(len=*),intent(out),optional :: ERRMSG !! !!##DESCRIPTION !! !! LOCATE_(3f) finds the index where the VALUE is found or should !! be found in an array. The array must be sorted in descending !! order (highest at top). If VALUE is not found it returns the index !! where the name should be placed at with a negative sign. !! !! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL,INTEGER) !! !!##OPTIONS !! !! VALUE the value to locate in the list. !! LIST is the list array. !! !!##RETURNS !! PLACE is the subscript that the entry was found at if it is !! greater than zero(0). !! !! If PLACE is negative, the absolute value of !! PLACE indicates the subscript value where the !! new entry should be placed in order to keep the !! list alphabetized. !! !! IER is zero(0) if no error occurs. !! If an error occurs and IER is not !! present, the program is stopped. !! !! ERRMSG description of any error !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_locate !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! call update(arr,'b') !! call update(arr,'[') !! call update(arr,'c') !! call update(arr,'ZZ') !! call update(arr,'ZZZZ') !! call update(arr,'z') !! !! contains !! subroutine update(arr,string) !! character(len=:),intent(in),allocatable :: arr(:) !! character(len=*),intent(in) :: string !! integer :: place, plus, ii, end !! ! find where string is or should be !! call locate_(arr,string,place) !! write(*,*)'for \"'//string//'\" index is ',place, size(arr) !! ! if string was not found insert it !! if(place < 1)then !! plus=abs(place) !! ii=len(arr) !! end=size(arr) !! ! empty array !! if(end == 0)then !! arr=[character(len=ii) :: string ] !! ! put in front of array !! elseif(plus == 1)then !! arr=[character(len=ii) :: string, arr] !! ! put at end of array !! elseif(plus == end)then !! arr=[character(len=ii) :: arr, string ] !! ! put in middle of array !! else !! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] !! endif !! ! show array !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! endif !! end subroutine update !! end program demo_locate !! !! Results: !! !! for \"b\" index is 2 5 !! for \"[\" index is -4 5 !! SIZE=5 xxx,b,aaa,[,ZZZ, !! for \"c\" index is -2 6 !! SIZE=6 xxx,c,b,aaa,[,ZZZ, !! for \"ZZ\" index is -7 7 !! SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! for \"ZZZZ\" index is -6 8 !! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! for \"z\" index is -1 9 !! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine locate_c ( list , value , place , ier , errmsg ) ! ident_29=\"@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed\" character ( len =* ), intent ( in ) :: value integer , intent ( out ) :: place character ( len = :), allocatable :: list (:) integer , intent ( out ), optional :: ier character ( len =* ), intent ( out ), optional :: errmsg integer :: i character ( len = :), allocatable :: message integer :: arraysize integer :: maxtry integer :: imin , imax integer :: error if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif arraysize = size ( list ) error = 0 if ( arraysize == 0 ) then maxtry = 0 place =- 1 else maxtry = nint ( log ( float ( arraysize )) / log ( 2.0 ) + 1.0 ) place = ( arraysize + 1 ) / 2 endif imin = 1 imax = arraysize message = '' LOOP : block do i = 1 , maxtry if ( value == list ( PLACE )) then exit LOOP elseif ( value > list ( place )) then imax = place - 1 else imin = place + 1 endif if ( imin > imax ) then place =- imin if ( iabs ( place ) > arraysize ) then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place = ( imax + imin ) / 2 if ( place > arraysize . or . place <= 0 ) then message = '*locate_* error: search is out of bounds of list. Probably an unsorted input array' error =- 1 exit LOOP endif enddo message = '*locate_* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if ( present ( ier )) then ier = error elseif ( error /= 0 ) then write ( warn , * ) message // ' VALUE=' , trim ( value ) // ' PLACE=' , place call mystop ( - 24 , '(*locate_c* ' // message ) endif if ( present ( errmsg )) then errmsg = message endif end subroutine locate_c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine remove_(list,place) !! !! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! Remove a value from an allocatable array at the specified index. !! The array is assumed to be sorted in descending order. It may be of !! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! !!##OPTIONS !! !! list is the list array. !! PLACE is the subscript for the entry that should be removed !! !!##EXAMPLES !! !! !! Sample program !! !! program demo_remove !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, remove_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! integer :: end !! !! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,1) !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,4) !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! !! end program demo_remove !! !! Results: !! !! Expected output !! !! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=7 bb,b,b,aaa,ZZZ,Z,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine remove_c ( list , place ) ! ident_30=\"@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position\" character ( len = :), allocatable :: list (:) integer , intent ( in ) :: place integer :: ii , end if (. not . allocated ( list )) then list = [ character ( len = 2 ) :: ] endif ii = len ( list ) end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ character ( len = ii ) :: list (: place - 1 ) ] else list = [ character ( len = ii ) :: list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_c subroutine remove_l ( list , place ) ! ident_31=\"@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position\" logical , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ list (: place - 1 )] else list = [ list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_l subroutine remove_i ( list , place ) ! ident_32=\"@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position\" integer , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ list (: place - 1 )] else list = [ list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! replace_(3f) - [M_CLI2] replace entry in a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine replace_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! replace a value in an allocatable array at the specified index. Unless the !! array needs the string length to increase this is merely an assign of a value !! to an array element. !! !! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> !! It is assumed to be sorted in descending order without duplicate values. !! !! The value and list must be of the same type. !! !!##OPTIONS !! !! VALUE the value to place in the array !! LIST is the array. !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Replace key-value pairs in a dictionary !! !! program demo_replace !! use M_CLI2, only : insert_, locate_, replace_ !! ! Find if a key is in a list and insert it !! ! into the key list and value list if it is not present !! ! or replace the associated value if the key existed !! implicit none !! character(len=20) :: key !! character(len=100) :: val !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer :: i !! integer :: place !! call update('b','value of b') !! call update('a','value of a') !! call update('c','value of c') !! call update('c','value of c again') !! call update('d','value of d') !! call update('a','value of a again') !! ! show array !! write(*,'(*(a,\"==>\",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) !! !! call locate_key('a',place) !! if(place > 0)then !! write(*,*)'The value of \"a\" is',trim(values(place)) !! else !! write(*,*)'\"a\" not found' !! endif !! !! contains !! subroutine update(key,val) !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: val !! integer :: place !! !! ! find where string is or should be !! call locate_key(key,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(keywords,key,abs(place)) !! call insert_(values,val,abs(place)) !! else ! replace !! call replace_(values,val,place) !! endif !! !! end subroutine update !! end program demo_replace_ !! !! Expected output !! !! d==>value of d !! c==>value of c again !! b==>value of b !! a==>value of a again !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine replace_c ( list , value , place ) ! ident_33=\"@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position\" character ( len =* ), intent ( in ) :: value character ( len = :), allocatable :: list (:) character ( len = :), allocatable :: kludge (:) integer , intent ( in ) :: place integer :: ii integer :: tlen integer :: end if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif tlen = len_trim ( value ) end = size ( list ) if ( place < 0. or . place > end ) then write ( warn , * ) '*replace_c* error: index out of range. end=' , end , ' index=' , place elseif ( len_trim ( value ) <= len ( list )) then list ( place ) = value else ! increase length of variable ii = max ( tlen , len ( list )) kludge = [ character ( len = ii ) :: list ] list = kludge list ( place ) = value endif end subroutine replace_c subroutine replace_l ( list , value , place ) ! ident_34=\"@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position\" logical , allocatable :: list (:) logical , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place > 0. and . place <= end ) then list ( place ) = value else ! put in middle of array write ( warn , * ) '*replace_l* error: index out of range. end=' , end , ' index=' , place endif end subroutine replace_l subroutine replace_i ( list , value , place ) ! ident_35=\"@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position\" integer , intent ( in ) :: value integer , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place > 0. and . place <= end ) then list ( place ) = value else ! put in middle of array write ( warn , * ) '*replace_i* error: index out of range. end=' , end , ' index=' , place endif end subroutine replace_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! insert_(3f) - [M_CLI2] insert entry into a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine insert_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer,intent(in) :: place !! !!##DESCRIPTION !! !! Insert a value into an allocatable array at the specified index. !! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL, or INTEGER) !! !!##OPTIONS !! !! list is the list array. Must be sorted in descending order. !! value the value to place in the array !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_insert !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, insert_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! ! add or replace values !! call update(arr,'b') !! call update(arr,'[') !! call update(arr,'c') !! call update(arr,'ZZ') !! call update(arr,'ZZZ') !! call update(arr,'ZZZZ') !! call update(arr,'') !! call update(arr,'z') !! !! contains !! subroutine update(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, end !! !! end=size(arr) !! ! find where string is or should be !! call locate_(arr,string,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(arr,string,abs(place)) !! endif !! ! show array !! end=size(arr) !! write(*,'(\"array is now SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! !! end subroutine update !! end program demo_insert_ !! !! Results: !! !! array is now SIZE=5 xxx,b,aaa,ZZZ,, !! array is now SIZE=6 xxx,b,aaa,[,ZZZ,, !! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, !! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine insert_c ( list , value , place ) ! ident_36=\"@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position\" character ( len =* ), intent ( in ) :: value character ( len = :), allocatable :: list (:) character ( len = :), allocatable :: kludge (:) integer , intent ( in ) :: place integer :: ii integer :: end if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif ii = max ( len_trim ( value ), len ( list ), 2 ) end = size ( list ) if ( end == 0 ) then ! empty array list = [ character ( len = ii ) :: value ] elseif ( place == 1 ) then ! put in front of array kludge = [ character ( len = ii ) :: value , list ] list = kludge elseif ( place > end ) then ! put at end of array kludge = [ character ( len = ii ) :: list , value ] list = kludge elseif ( place >= 2. and . place <= end ) then ! put in middle of array kludge = [ character ( len = ii ) :: list (: place - 1 ), value , list ( place :) ] list = kludge else ! index out of range write ( warn , * ) '*insert_c* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_c subroutine insert_l ( list , value , place ) ! ident_37=\"@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position\" logical , allocatable :: list (:) logical , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place == 1 ) then ! put in front of array list = [ value , list ] elseif ( place > end ) then ! put at end of array list = [ list , value ] elseif ( place >= 2. and . place <= end ) then ! put in middle of array list = [ list (: place - 1 ), value , list ( place :) ] else ! index out of range write ( warn , * ) '*insert_l* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_l subroutine insert_i ( list , value , place ) ! ident_38=\"@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position\" integer , allocatable :: list (:) integer , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place == 1 ) then ! put in front of array list = [ value , list ] elseif ( place > end ) then ! put at end of array list = [ list , value ] elseif ( place >= 2. and . place <= end ) then ! put in middle of array list = [ list (: place - 1 ), value , list ( place :) ] else ! index out of range write ( warn , * ) '*insert_i* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine many_args ( n0 , g0 , n1 , g1 , n2 , g2 , n3 , g3 , n4 , g4 , n5 , g5 , n6 , g6 , n7 , g7 , n8 , g8 , n9 , g9 , & & na , ga , nb , gb , nc , gc , nd , gd , ne , ge , nf , gf , ng , gg , nh , gh , ni , gi , nj , gj ) ! ident_39=\"@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)\" character ( len =* ), intent ( in ) :: n0 , n1 character ( len =* ), intent ( in ), optional :: n2 , n3 , n4 , n5 , n6 , n7 , n8 , n9 , na , nb , nc , nd , ne , nf , ng , nh , ni , nj class ( * ), intent ( out ) :: g0 , g1 class ( * ), intent ( out ), optional :: g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 class ( * ), intent ( out ), optional :: ga , gb , gc , gd , ge , gf , gg , gh , gi , gj call get_generic ( n0 , g0 ) call get_generic ( n1 , g1 ) if ( present ( n2 ) . and . present ( g2 ) ) call get_generic ( n2 , g2 ) if ( present ( n3 ) . and . present ( g3 ) ) call get_generic ( n3 , g3 ) if ( present ( n4 ) . and . present ( g4 ) ) call get_generic ( n4 , g4 ) if ( present ( n5 ) . and . present ( g5 ) ) call get_generic ( n5 , g5 ) if ( present ( n6 ) . and . present ( g6 ) ) call get_generic ( n6 , g6 ) if ( present ( n7 ) . and . present ( g7 ) ) call get_generic ( n7 , g7 ) if ( present ( n8 ) . and . present ( g8 ) ) call get_generic ( n8 , g8 ) if ( present ( n9 ) . and . present ( g9 ) ) call get_generic ( n9 , g9 ) if ( present ( na ) . and . present ( ga ) ) call get_generic ( na , ga ) if ( present ( nb ) . and . present ( gb ) ) call get_generic ( nb , gb ) if ( present ( nc ) . and . present ( gc ) ) call get_generic ( nc , gc ) if ( present ( nd ) . and . present ( gd ) ) call get_generic ( nd , gd ) if ( present ( ne ) . and . present ( ge ) ) call get_generic ( ne , ge ) if ( present ( nf ) . and . present ( gf ) ) call get_generic ( nf , gf ) if ( present ( ng ) . and . present ( gg ) ) call get_generic ( ng , gg ) if ( present ( nh ) . and . present ( gh ) ) call get_generic ( nh , gh ) if ( present ( ni ) . and . present ( gi ) ) call get_generic ( ni , gi ) if ( present ( nj ) . and . present ( gj ) ) call get_generic ( nj , gj ) contains !=================================================================================================================================== function c ( generic ) class ( * ), intent ( in ) :: generic character ( len = :), allocatable :: c select type ( generic ) type is ( character ( len =* )); c = trim ( generic ) class default c = 'unknown' stop 'get_many:: parameter name is not character' end select end function c !=================================================================================================================================== subroutine get_generic ( name , generic ) use , intrinsic :: iso_fortran_env , only : real64 character ( len =* ), intent ( in ) :: name class ( * ), intent ( out ) :: generic select type ( generic ) type is ( integer ); call get_args ( name , generic ) type is ( real ); call get_args ( name , generic ) type is ( real ( kind = real64 )); call get_args ( name , generic ) type is ( logical ); call get_args ( name , generic ) !x!type is (character(len=:),allocatable ::); call get_args(name,generic) type is ( character ( len =* )); call get_args_fixed_length ( name , generic ) type is ( complex ); call get_args ( name , generic ) class default stop 'unknown type in *get_generic*' end select end subroutine get_generic !=================================================================================================================================== end subroutine many_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function iget ( n ); integer :: iget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , iget ); end function iget function rget ( n ); real :: rget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , rget ); end function rget function dget ( n ); real ( kind = dp ) :: dget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , dget ); end function dget function sget ( n ); character ( len = :), allocatable :: sget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , sget ); end function sget function cget ( n ); complex :: cget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , cget ); end function cget function lget ( n ); logical :: lget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , lget ); end function lget function igs ( n ); integer , allocatable :: igs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , igs ); end function igs function rgs ( n ); real , allocatable :: rgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , rgs ); end function rgs function dgs ( n ); real ( kind = dp ), allocatable :: dgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , dgs ); end function dgs function sgs ( n , delims ) character ( len = :), allocatable :: sgs (:) character ( len =* ), optional , intent ( in ) :: delims character ( len =* ), intent ( in ) :: n call get_args ( n , sgs , delims ) end function sgs function cgs ( n ); complex , allocatable :: cgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , cgs ); end function cgs function lgs ( n ); logical , allocatable :: lgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , lgs ); end function lgs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function ig () integer , allocatable :: ig (:) integer :: i , ierr if ( allocated ( ig )) deallocate ( ig ) allocate ( ig ( size ( unnamed ))) do i = 1 , size ( ig ) call a2i ( unnamed ( i ), ig ( i ), ierr ) enddo end function ig !=================================================================================================================================== function rg () real , allocatable :: rg (:) rg = real ( dg ()) end function rg !=================================================================================================================================== function dg () real ( kind = dp ), allocatable :: dg (:) integer :: i integer :: ierr if ( allocated ( dg )) deallocate ( dg ) allocate ( dg ( size ( unnamed ))) do i = 1 , size ( dg ) call a2d ( unnamed ( i ), dg ( i ), ierr ) enddo end function dg !=================================================================================================================================== function lg () logical , allocatable :: lg (:) integer :: i integer :: iichar character , allocatable :: hold if ( allocated ( lg )) deallocate ( lg ) allocate ( lg ( size ( unnamed ))) do i = 1 , size ( lg ) hold = trim ( upper ( adjustl ( unnamed ( i )))) if ( hold ( 1 : 1 ) == '.' ) then ! looking for fortran logical syntax .STRING. iichar = 2 else iichar = 1 endif select case ( hold ( iichar : iichar )) ! check word to see if true or false case ( 'T' , 'Y' , ' ' ); lg ( i ) = . true . ! anything starting with \"T\" or \"Y\" or a blank is TRUE (true,yes,...) case ( 'F' , 'N' ); lg ( i ) = . false . ! assume this is false or no case default call journal ( 'sc' , \"*lg* bad logical expression for element\" , i , '=' , hold ) end select enddo end function lg !=================================================================================================================================== function cg () complex , allocatable :: cg (:) integer :: i , ierr real ( kind = dp ) :: rc , ic if ( allocated ( cg )) deallocate ( cg ) allocate ( cg ( size ( unnamed ))) do i = 1 , size ( cg ), 2 call a2d ( unnamed ( i ), rc , ierr ) call a2d ( unnamed ( i + 1 ), ic , ierr ) cg ( i ) = cmplx ( rc , ic , kind = sp ) enddo end function cg !=================================================================================================================================== ! Does not work with gcc 5.3 !function sg() !character(len=:),allocatable :: sg(:) ! sg=unnamed !end function sg function sg () character ( len = :), allocatable :: sg (:) if ( allocated ( sg )) deallocate ( sg ) allocate ( sg , source = unnamed ) end function sg !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine mystop ( sig , msg ) ! negative signal means always stop program ! else do not stop and set G_STOP_MESSAGE if G_QUIET is true ! or ! print message and stop if G_QUIET is false ! the MSG is NOT for displaying except for internal errors when the program will be stopped. ! It is for returning a value when the stop is being ignored ! integer , intent ( in ) :: sig character ( len =* ), intent ( in ), optional :: msg !x!write(*,*)'MYSTOP:',sig,trim(msg) if ( sig < 0 ) then if ( present ( msg )) call journal ( 'sc' , msg ) !x!stop abs(sig) stop 1 elseif (. not . G_QUIET ) then stop else if ( present ( msg )) then G_STOP_MESSAGE = msg else G_STOP_MESSAGE = '' endif G_STOP = sig !x!write(*,*)'G_STOP:',g_stop,trim(msg) endif end subroutine mystop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function atleast ( line , length , pattern ) result ( strout ) ! ident_40=\"@(#) M_strings atleast(3f) return string padded to at least specified length\" character ( len =* ), intent ( in ) :: line integer , intent ( in ) :: length character ( len =* ), intent ( in ), optional :: pattern character ( len = max ( length , len ( trim ( line )))) :: strout if ( present ( pattern )) then strout = line // repeat ( pattern , len ( strout ) / len ( pattern ) + 1 ) else strout = line endif end function atleast !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine locate_key ( value , place ) ! ident_41=\"@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed\" character ( len =* ), intent ( in ) :: value integer , intent ( out ) :: place integer :: ii character ( len = :), allocatable :: value_local if ( G_UNDERDASH ) then value_local = trim ( replace_str ( value , '-' , '_' )) else value_local = trim ( value ) endif if ( G_IGNORECASE . and . len ( value_local ) > 1 ) value_local = lower ( value_local ) if ( len ( value_local ) == 1 ) then !x!ii=findloc(shorts,value_local,dim=1) ii = maxloc ([ 0 , merge ( 1 , 0 , shorts == value_local )], dim = 1 ) if ( ii > 1 ) then place = ii - 1 else call locate_ ( keywords , value_local , place ) endif else call locate_ ( keywords , value_local , place ) endif end subroutine locate_key !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_mode(key,mode) !! !! character(len=*),intent(in) :: key !! logical,intent(in),optional :: mode !! !!##DESCRIPTION !! Allow optional behaviors. !! !!##OPTIONS !! KEY name of option !! o response_file - enable use of response file !! o ignorecase - ignore case in long key names !! o underdash - treat dash in keyname as an underscore !! o strict - allow boolean keys to be bundled, but requires !! a single dash prefix be used for short key names and !! long names to be prefixed with two dashes. !! !! MODE set to .true. to activate the optional mode. !! Set to .false. to deactivate the mode. !! It is .true. by default. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_set_mode !! use M_CLI2, only : set_args, lget, set_mode !! implicit none !! character(len=*),parameter :: all='(*(g0))' !! ! !! ! enable use of response files !! call set_mode('response_file') !! ! !! ! Any dash in a keyname is treated as an underscore !! call set_mode('underdash') !! ! !! ! The case of long keynames are ignored. !! ! Values and short names remain case-sensitive !! call set_mode('ignorecase') !! ! !! ! short single-character boolean keys may be bundled !! ! but it is required that a single dash is used for !! ! short keys and a double dash for long keynames. !! call set_mode('strict') !! ! !! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F') !! ! !! print all,'--switch_X or -X ... ',lget('switch_X') !! print all,'--switch_Y or -Y ... ',lget('switch_Y') !! print all,'--ox or -O ... ',lget('ox') !! print all,'-o ... ',lget('o') !! print all,'-x ... ',lget('x') !! print all,'-t ... ',lget('t') !! end program demo_set_mode !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure subroutine set_mode ( key , mode ) character ( len =* ), intent ( in ) :: key logical , intent ( in ), optional :: mode logical :: local_mode if ( present ( mode )) then local_mode = mode else local_mode = . true . endif select case ( lower ( key )) case ( 'response_file' , 'response file' ); CLI_RESPONSE_FILE = local_mode case ( 'debug' ); G_DEBUG = local_mode case ( 'ignorecase' ); G_IGNORECASE = local_mode case ( 'underdash' ); G_UNDERDASH = local_mode case ( 'strict' ); G_STRICT = local_mode case default call journal ( 'sc' , 'set_mode* unknown key name ' , key ) end select end subroutine set_mode !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_CLI2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !===================================================================================================================================","tags":"","loc":"sourcefile/m_cli2.f90.html"},{"title":"hello.f90 – M_CLI2","text":"Contents Programs demo3 Source Code hello.f90 Source Code program demo3 !! example of **basic** use !*! JUST THE BARE ESSENTIALS use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size:s 12.34567 -l F --title:t \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"sourcefile/hello.f90.html"},{"title":"demo11.f90 – M_CLI2","text":"Contents Programs demo11 Source Code demo11.f90 Source Code program demo11 !! @(#) examples of validating values with ALL(3f) and ANY(3f) use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT implicit none type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point type ( point ) :: dot ; namelist / nml_dot / dot character ( len = :), allocatable :: name character ( len = :), allocatable :: string character ( len = 80 ) :: readme !(3) integer :: i ! M_CLI2 does not have validators except for SPECIFIED(3f) and ! a check whether the input conforms to the type with get_args(3f) ! and the convenience functions like inum(3f). But Fortran already ! has powerful validation capabilities, especially with the use ! of logical expressions, and ANY(3f) and ALL(3f). ! A somewhat contrived example of using ALL(3f): ! even number from 10 to 30 inclusive do i = 1 , 100 if ( all ([ i >= 10 , i <= 30 ,( i / 2 ) * 2 == i ])) then write ( * , * ) 'good' , i endif enddo ! an example of using ANY(3f) ! matched name = 'red' if ( any ( name == [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ])) then write ( * , * ) 'matches ' , name endif ! not matched name = 'teal' if ( any ( name == [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ])) then write ( * , * ) 'matches ' , name endif ! and even user-defined types can be processed by reading the input ! as a string and using a NAMELIST(3f) group to convert it. Note that ! if input values are strings that have to be quoted (ie. more than one ! word) or contain characters special to the shell that how you have to ! quote the command line can get complicated. string = '10,20,\"green\"' readme = '&nml_dot dot=' // string // '/' ! some compilers might require the input to be on three lines !readme=[ character(len=80) ::& !'&nml_dot', & !'dot='//string//' ,', & !'/'] read ( readme , nml = nml_dot ) write ( * , * ) dot % x , dot % y , dot % color ! or write ( * , nml_dot ) ! Hopefully it is obvious how the options can be read from values gotten ! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f) ! in the first case, so this example just uses simple declarations to highlight ! some useful Fortran expressions that can be useful for validating the input ! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups. ! another alternative would be to validate expressions from strings using M_calculator(3f) ! but I find it easier to validate the values using regular Fortran code than doing it ! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by ! M_CLI2(3f) doing validation in the input forms themselves would be more desirable. end program demo11","tags":"","loc":"sourcefile/demo11.f90.html"},{"title":"demo10.f90 – M_CLI2","text":"Contents Programs demo10 Source Code demo10.f90 Source Code program demo10 !! @(#) full usage and even equivalencing use M_CLI2 , only : set_args , get_args , unnamed use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : specified ! only needed if equivalence keynames implicit none integer :: i !! DECLARE \"ARGS\" real :: x , y , z real :: point ( 3 ), p ( 3 ) character ( len = 80 ) :: title logical :: l , l_ equivalence ( point , p ) !! WHEN DEFINING THE PROTOTYPE ! o All parameters must be listed with a default value ! o string values must be double-quoted ! o numeric lists must be comma-delimited. No spaces are allowed ! o long keynames must be all lowercase !! SET ALL ARGUMENTS TO DEFAULTS AND THEN ADD IN COMMAND LINE VALUES call set_args ( '-x 1 -y 2 -z 3 --point -1,-2,-3 --p -1,-2,-3 --title \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) ! note these are equivalenced so one of the calls must be conditional call get_args_fixed_size ( 'point' , point ) if ( specified ( 'p' )) call get_args_fixed_size ( 'p' , p ) ! if for some reason you want to use a fixed-length string use ! get_args_fixed_length(3f) instead of get_args(3f) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z write ( * , * ) 'point=' , point , 'p=' , p write ( * , * ) 'title=' , trim ( title ) write ( * , * ) 'l=' , l , 'L=' , l_ ! ! the optional unnamed values on the command line are ! accumulated in the character array \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif end program demo10","tags":"","loc":"sourcefile/demo10.f90.html"},{"title":"demo4.f90 – M_CLI2","text":"Contents Programs demo4 Source Code demo4.f90 Source Code program demo4 !! @(#) _COMPLEX_ type values use M_CLI2 , only : set_args , get_args , get_args_fixed_size implicit none complex :: x , y , z ! scalars complex , allocatable :: aarr (:) ! allocatable array complex :: three ( 3 ) ! fixed-size array ! formats to pretty-print a complex value and small complex vector character ( len =* ), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character ( len =* ), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' ! COMPLEX VALUES ! ! o parenthesis are optional and are ignored in complex values. ! ! o base#value is acceptable for base 2 to 32 for whole numbers, ! which is why \"i\" is not allowed as a suffix on imaginary values ! (because some bases include \"i\" as a digit). ! ! o normally arrays are allocatable. if a fixed size array is used ! call get_args_fixed_size(3f) and all the values must be ! specified. This is useful when you have something that requires ! a specific number of values. Perhaps a point in space must always ! have three values, for example. ! ! o default delimiters are whitespace, comma and colon. Note that ! whitespace delimiters should not be used in the definition, ! but are OK on command input if the entire parameter value is ! quoted. Using space delimiters in the prototype definition is ! not supported (but works) and requires that the value be quoted ! on input in common shells. Adjacent delimiters are treated as ! a single delimiter. ! call set_args ( '-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444' ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'three' , three ) call get_args ( 'aarr' , aarr ) write ( * , form ) x , y , z , x + y + z write ( * , forms ) three write ( * , forms ) aarr end program demo4 ! ! expected output: ! ! (1.00000000,2.00000000i) ! (10.0000000,20.0000000i) ! (7.00000000,-171.000000i) ! (18.0000000,-149.000000i) ! (1.00000000,2.00000000i), (3.00000000,4.00000000i), (5.00000000,6.00000000i) ! (111.000000,222.000000i), (333.000000,444.000000i)","tags":"","loc":"sourcefile/demo4.f90.html"},{"title":"demo14.f90 – M_CLI2","text":"Contents Programs demo14 Source Code demo14.f90 Source Code program demo14 !> @(#) ignorecase mode !! !! long keynames are internally converted to lowercase !! when ignorecase mode is on these are equivalent !! !! demo14 --longName !! demo14 --longname !! demo14 --LongName !! !! Values and short names remain case-sensitive !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'ignorecase' ) call set_args ( ' --longName:N F ' ) print all , '--longName or -N ... ' , lget ( 'longName' ) end program demo14","tags":"","loc":"sourcefile/demo14.f90.html"},{"title":"demo3.f90 – M_CLI2","text":"Contents Programs demo3 Source Code demo3.f90 Source Code program demo3 !! @(#) example of **basic** use using just the bare essentials use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! Done. all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"sourcefile/demo3.f90.html"},{"title":"demo2.f90 – M_CLI2","text":"Contents Programs demo2 Source Code demo2.f90 Source Code program demo2 !! @(#) all parsing and **help** and **version** information in a contained procedure. use M_CLI2 , only : unnamed implicit none integer :: i !! DEFINE \"ARGS\" VALUES integer :: x , y , z real :: point ( 3 ) character ( len = 80 ) :: title logical :: l , l_ call parse () !! DEFINE AND PARSE COMMAND LINE !! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM. write ( * , * ) x + y + z write ( * , * ) point * 2 write ( * , * ) title write ( * , * ) l , l_ !! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE !! ACCUMULATED IN THE CHARACTER ARRAY \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif contains subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse end program demo2","tags":"","loc":"sourcefile/demo2.f90.html"},{"title":"demo15.f90 – M_CLI2","text":"Contents Programs demo15 Source Code demo15.f90 Source Code program demo15 !> @(#) strict mode !! !! In strict mode short single-character names may be bundled but it is !! required that a single dash is used, where normally single and double !! dashes are equivalent. !! !! demo15 -o -t -x !! demo15 -otx !! demo15 -xto !! !! Only Boolean keynames may be bundled together !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'strict' ) call set_args ( ' -o F -t F -x F --ox F' ) print all , 'o=' , lget ( 'o' ), ' t=' , lget ( 't' ), ' x=' , lget ( 'x' ), ' ox=' , lget ( 'ox' ) end program demo15","tags":"","loc":"sourcefile/demo15.f90.html"},{"title":"demo6.f90 – M_CLI2","text":"Contents Programs demo6 Source Code demo6.f90 Source Code program demo6 !! @(#) SUBCOMMANDS !! !! For a command with subcommands like git(1) you can call this program !! which has two subcommands (run, test), like this: !! !! demo6 --help !! demo6 run -x -y -z -title -l -L !! demo6 test -title -l -L -testname !! demo6 run --help !! use M_CLI2 , only : set_args , get_args , get_args_fixed_length , get_subcommand use M_CLI2 , only : rget , sget , lget use M_CLI2 , only : CLI_RESPONSE_FILE implicit none character ( len = :), allocatable :: name ! the subcommand name character ( len = :), allocatable :: version_text (:), help_text (:) ! define some values to use as arguments character ( len = 80 ) :: title , testname logical :: l , l_ version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo6 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] CLI_RESPONSE_FILE = . true . ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () ! define commands and parse command line and set help text and process command select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , help_text , version_text ) ! example using convenience functions to retrieve values and pass them ! to a routine call my_run ( rget ( 'x' ), rget ( 'y' ), rget ( 'z' ), sget ( 'title' ), lget ( 'l' ), lget ( 'L' )) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( '--title \"my title\" -l F -L F --testname \"Test\"' , help_text , version_text ) ! use get_args(3f) to extract values and use them call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) ! all done cracking the command line. use the values in your program. write ( * , * ) 'command was ' , name write ( * , * ) 'title .... ' , trim ( title ) write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , trim ( testname ) case ( '' ) ! general help for \"demo6 --help\" help_text = [ character ( len = 80 ) :: & ' General help describing the ' , & ' program. ' , & '' ] call set_args ( ' ' , help_text , version_text ) ! process help and version case default call set_args ( ' ' , help_text , version_text ) ! process help and version write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' end select contains subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run end program demo6","tags":"","loc":"sourcefile/demo6.f90.html"},{"title":"demo12.f90 – M_CLI2","text":"Contents Programs demo12 Source Code demo12.f90 Source Code program demo12 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , rget implicit none real :: x , y , z !! ENABLE USING RESPONSE FILES call set_mode ( 'response file' ) call set_args ( '-x 1.1 -y 2e3 -z -3.9 ' ) x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z end program demo12","tags":"","loc":"sourcefile/demo12.f90.html"},{"title":"demo7.f90 – M_CLI2","text":"Contents Programs demo7 Source Code demo7.f90 Source Code program demo7 !! @(#) controlling array delimiter characters use M_CLI2 , only : set_args , get_args , get_args_fixed_size , get_args_fixed_length implicit none integer , parameter :: dp = kind ( 0.0d0 ) character ( len = 20 ), allocatable :: flen (:) ! allocatable array with fixed length character ( len = 4 ) :: fixed ( 2 ) ! fixed-size array wih fixed length integer , allocatable :: integers (:) real , allocatable :: reals (:) real ( kind = dp ), allocatable :: doubles (:) real ( kind = dp ), allocatable :: normal (:) complex , allocatable :: complexs (:) character ( len = :), allocatable :: characters (:) ! allocatable array with allocatable length ! ARRAY DELIMITERS ! ! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f) ! call set_args ( '-flen A,B,C -fixed X,Y --integers z --reals 111/222/333 -normal , --doubles | --complexs 0!0 --characters @' ) call get_args ( 'integers' , integers , delimiters = 'abcdefghijklmnopqrstuvwxyz' ) call get_args ( 'reals' , reals , delimiters = '/' ) call get_args ( 'doubles' , doubles , delimiters = '|' ) call get_args ( 'complexs' , complexs , delimiters = '!' ) call get_args ( 'normal' , normal ) call get_args ( 'characters' , characters , delimiters = '@' ) call get_args_fixed_length ( 'flen' , flen ) call get_args_fixed_size ( 'fixed' , fixed ) ! fixed length and fixed size array write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( flen ), 'flen=' , flen write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( characters ), 'characters=' , characters write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( integers ), 'integers=' , integers write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( reals ), 'reals=' , reals write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( doubles ), 'doubles=' , doubles write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( complexs ), 'complexs=' , complexs write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( normal ), 'normal=' , normal write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( fixed ), 'fixed=' , fixed end program demo7 !================================================================================================================================== ! EXAMPLE CALL ! demo7 -integers 1a2b3c4d5e6 -reals 1/2/3/4 -doubles '40|50|60' -complexs '2!3!4!5' --characters aaa@BBBB@c,d,e ! EXPECTED OUTPUT ! 3 characters=[aaa ] [BBBB ] [c,d,e] ! 6 integers=[1] [2] [3] [4] [5] [6] ! 4 reals=[1.00000000] [2.00000000] [3.00000000] [4.00000000] ! 3 doubles=[40.000000000000000] [50.000000000000000] [60.000000000000000] ! 0 normal=[ ! 2 complexs=[2.00000000] [3.00000000] [4.00000000] [5.00000000] ! 2 fixed=[X ] [Y ] !==================================================================================================================================","tags":"","loc":"sourcefile/demo7.f90.html"},{"title":"demo8.f90 – M_CLI2","text":"Contents Programs demo8 Source Code demo8.f90 Source Code program demo8 !! @(#) Sometimes you can put multiple values on getargs(3f) use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = 80 ) :: title character ( len =* ), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' ! DEFINE COMMAND AND PARSE COMMAND LINE ! set all values, double-quote strings call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! GET THE VALUES ! only fixed scalar values (including only character variables that ! are fixed length) may be combined in one GET_ARGS(3f) call call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size , 'title' , title ) ! USE THE VALUES write ( * , fmt = pairs ) 'X' , x , 'Y' , y , 'size' , size , 'L' , l , 'TITLE' , title end program demo8","tags":"","loc":"sourcefile/demo8.f90.html"},{"title":"demo13.f90 – M_CLI2","text":"Contents Programs demo13 Source Code demo13.f90 Source Code program demo13 !> @(#) underdash mode !! Any dash in a key name is treated as an underscore !! when underdash mode is on !! !! demo13 --switch-X !! demo13 --switch_X !! !! are equivalent when this mode is on !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_mode ( 'underdash' ) call set_args ( ' --switch_X:X F --switch-Y:Y F ' ) print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) end program demo13","tags":"","loc":"sourcefile/demo13.f90.html"},{"title":"demo9.f90 – M_CLI2","text":"Contents Programs demo9 Source Code demo9.f90 Source Code program demo9 !> @(#) long and short names using --LONGNAME:SHORTNAME !! !! When all keys have a long and short name \"strict mode\" is invoked where !! \"-\" is required for short names; and Boolean values may be bundled !! together. For example: !! !! demo9 -XYZ !! use M_CLI2 , only : set_args , sget , rget , lget implicit none character ( len =* ), parameter :: all = '(*(g0))' call set_args ( ' & & --length:l 10 & & --height:h 12.45 & & --switchX:X F & & --switchY:Y F & & --switchZ:Z F & & --title:T \"my title\"' ) print all , '--length or -l .... ' , rget ( 'length' ) print all , '--height or -h .... ' , rget ( 'height' ) print all , '--switchX or -X ... ' , lget ( 'switchX' ) print all , '--switchY or -Y ... ' , lget ( 'switchY' ) print all , '--switchZ or -Z ... ' , lget ( 'switchZ' ) print all , '--title or -T ..... ' , sget ( 'title' ) end program demo9","tags":"","loc":"sourcefile/demo9.f90.html"},{"title":"demo5.f90 – M_CLI2","text":"Contents Programs demo5 Source Code demo5.f90 Source Code program demo5 !! @(#) _CHARACTER_ type values !! character variables have a length, unlike number variables use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : sget , sgets implicit none character ( len =* ), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' call set_args ( ' & & --alloc_len_scalar \" \" --fx_len_scalar \" \" & & --alloc_array \"A,B,C\" & & --fx_size_fx_len \"A,B,C\" & & --fx_len_alloc_array \"A,B,C\" & & ' ) block ! you just need get_args(3f) for general scalars or arrays ! variable length scalar character ( len = :), allocatable :: alloc_len_scalar ! variable array size and variable length character ( len = :), allocatable :: alloc_array (:) call get_args ( 'alloc_len_scalar' , alloc_len_scalar ) write ( * , fmt ) 'allocatable length scalar=' , alloc_len_scalar ,& & len ( alloc_len_scalar ) call get_args ( 'alloc_array' , alloc_array ) write ( * , fmt ) 'allocatable array= ' , alloc_array endblock ! less commonly, if length or size is fixed, use a special function block character ( len = 19 ), allocatable :: fx_len_alloc_array (:) call get_args_fixed_length ( 'fx_len_alloc_array' , fx_len_alloc_array ) write ( * , fmt ) 'fixed length allocatable array=' , fx_len_alloc_array endblock block character ( len = 19 ) :: fx_len_scalar call get_args_fixed_length ( 'fx_len_scalar' , fx_len_scalar ) write ( * , fmt ) 'fixed length scalar= ' , fx_len_scalar endblock block character ( len = 19 ) :: fx_size_fx_len ( 3 ) call get_args_fixed_size ( 'fx_size_fx_len' , fx_size_fx_len ) write ( * , fmt ) 'fixed size fixed length= ' , fx_size_fx_len endblock block ! or (recommended) set to an allocatable array and check size and ! length returned character ( len = :), allocatable :: a ! variable length scalar character ( len = :), allocatable :: arr (:) ! variable array size and variable length call get_args ( 'fx_size_fx_len' , arr ) ! or arr = sgets ( 'fx_size_fx_len' ) if ( size ( arr ) /= 3 ) write ( * , * ) 'not right size' if ( len ( arr ) > 19 ) write ( * , * ) 'longer than wanted' call get_args ( 'fx_len_scalar' , a ) !or a = sget ( 'fx_len_scalar' ) if ( len ( a ) > 19 ) write ( * , * ) 'too long' write ( * , * ) a , len ( a ) write ( * , * ) arr , len ( arr ), size ( arr ) endblock end program demo5","tags":"","loc":"sourcefile/demo5.f90.html"},{"title":"demo1.f90 – M_CLI2","text":"Contents Programs demo1 Source Code demo1.f90 Source Code program demo1 !! @(#) using the convenience functions use M_CLI2 , only : set_args , get_args_fixed_size , set_mode use M_CLI2 , only : dget , iget , lget , rget , sget , cget ! for scalars use M_CLI2 , only : dgets , igets , lgets , rgets , sgets , cgets ! for allocatable arrays implicit none !! DECLARE \"ARGS\" real :: x , y , z , point ( 3 ) character ( len = :), allocatable :: title , anytitle logical :: l , lupper call set_mode ( 'response_file' ) !! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES call set_args ( '-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T \"my title\" --anytitle:a \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) l = lget ( 'l' ) lupper = lget ( 'L' ) title = sget ( 'title' ) anytitle = sget ( 'anytitle' ) ! With a fixed-size array to ensure the correct number of values are input use call get_args_fixed_size ( 'point' , point ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z , ' point=' , point write ( * , '(*(g0:,1x))' ) 'title=' , trim ( title ), ' l=' , l , 'L=' , lupper write ( * , '(*(g0:,1x))' ) 'anytitle=' , trim ( anytitle ) end program demo1 !! NOTES: WHEN DEFINING THE PROTOTYPE ! o All parameters must be listed with a default value ! o string values must be double-quoted ! o numeric lists must be comma-delimited. No spaces are allowed ! o long keynames must be all lowercase but may be followed by :LETTER where LETTER is a ! single letter that may be of any case that will act as a short name for the same value.","tags":"","loc":"sourcefile/demo1.f90.html"},{"title":"demo_set_mode.f90 – M_CLI2","text":"Contents Programs demo_set_mode Source Code demo_set_mode.f90 Source Code program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' ! ! enable use of response files call set_mode ( 'response_file' ) ! ! Any dash in a keyname is treated as an underscore call set_mode ( 'underdash' ) ! ! The case of long keynames are ignored. ! Values and short names remain case-sensitive call set_mode ( 'ignorecase' ) ! ! short single-character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keynames. call set_mode ( 'strict' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F' ) ! print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) print all , '--ox or -O ... ' , lget ( 'ox' ) print all , '-o ... ' , lget ( 'o' ) print all , '-x ... ' , lget ( 'x' ) print all , '-t ... ' , lget ( 't' ) end program demo_set_mode","tags":"","loc":"sourcefile/demo_set_mode.f90.html"},{"title":"demo_get_subcommand.f90 – M_CLI2","text":"Contents Programs demo_get_subcommand Source Code demo_get_subcommand.f90 Source Code program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z -title -l -L !x! demo_get_subcommand test -title -l -L -testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x =- 99 9.0 , y =- 99 9.0 , z =- 99 9.0 character ( len = 80 ) :: title = \"not set\" logical :: l = . false . logical :: l_ = . false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) !x! DEFINE AND PARSE COMMAND LINE !x! ALL DONE CRACKING THE COMMAND LINE. !x! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'command was ' , name write ( * , * ) 'x,y,z .... ' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , testname contains subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand","tags":"","loc":"sourcefile/demo_get_subcommand.f90.html"},{"title":"demo_get_args.f90 – M_CLI2","text":"Contents Programs demo_get_args Source Code demo_get_args.f90 Source Code program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! DEFINE ARGS real :: x , y , z real , allocatable :: p (:) character ( len = :), allocatable :: title logical :: l , lbig ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings and use double-quotes ! o set all logical values to F or T. call set_args ( ' & & -x 1 -y 2 -z 3 & & -p -1,-2,-3 & & --title \"my title\" & & -l F -L F & & --label \" \" & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( 'x' , x , 'y' , y , 'z' , z ) call get_args ( 'l' , l ) call get_args ( 'L' , lbig ) ! ALLOCATABLE STRING call get_args ( 'title' , title ) ! NON-ALLOCATABLE ARRAYS call get_args ( 'p' , p ) ! USE VALUES write ( * , '(1x,g0,\"=\",g0)' ) 'x' , x , 'y' , y , 'z' , z write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig if ( size ( filenames ) > 0 ) then write ( * , '(i6.6,3a)' )( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) endif end program demo_get_args","tags":"","loc":"sourcefile/demo_get_args.f90.html"},{"title":"demo_get_args_fixed_length.f90 – M_CLI2","text":"Contents Programs demo_get_args_fixed_length Source Code demo_get_args_fixed_length.f90 Source Code program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! DEFINE ARGS character ( len = 80 ) :: title call set_args ( ' & & --title \"my title\" & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_length ( 'title' , title ) ! USE VALUES write ( * , * ) 'title=' , title end program demo_get_args_fixed_length","tags":"","loc":"sourcefile/demo_get_args_fixed_length.f90.html"},{"title":"demo_specified.f90 – M_CLI2","text":"Contents Programs demo_specified Source Code demo_specified.f90 Source Code program demo_specified use M_CLI2 , only : set_args , get_args , specified implicit none ! DEFINE ARGS integer :: flag integer , allocatable :: ints (:) real , allocatable :: two_names (:) ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED ! NAMES BUT CURRENTLY YOU STILL SPECIFY THEM call set_args ( '& & --flag 1 -f 1 & & --ints 1,2,3 -i 1,2,3 & & --two_names 11.3 -T 11.3' ) ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME call get_args ( 'flag' , flag ) if ( specified ( 'f' )) call get_args ( 'f' , flag ) call get_args ( 'ints' , ints ) if ( specified ( 'i' )) call get_args ( 'i' , ints ) call get_args ( 'two_names' , two_names ) if ( specified ( 'T' )) call get_args ( 'T' , two_names ) ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE ! ANY(3f) and ALL(3f) write ( * , * ) specified ([ 'two_names' , 'T ' ]) write ( * , * ) 'ANY:' , any ( specified ([ 'two_names' , 'T ' ])) write ( * , * ) 'ALL:' , all ( specified ([ 'two_names' , 'T ' ])) ! FOR MUTUALLY EXCLUSIVE if ( all ( specified ([ 'two_names' , 'T ' ]))) then write ( * , * ) 'You specified both names -T and -two_names' endif ! FOR REQUIRED PARAMETER if (. not . any ( specified ([ 'two_names' , 'T ' ]))) then write ( * , * ) 'You must specify -T or -two_names' endif ! USE VALUES write ( * , * ) 'flag=' , flag write ( * , * ) 'ints=' , ints write ( * , * ) 'two_names=' , two_names end program demo_specified","tags":"","loc":"sourcefile/demo_specified.f90.html"},{"title":"demo_get_args_fixed_size.f90 – M_CLI2","text":"Contents Programs demo_get_args_fixed_size Source Code demo_get_args_fixed_size.f90 Source Code program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0.0d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ), lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings ! o set all logical values to F or T. call set_args ( ' & & -x 10.0,20.0 & & -y 11.0,22.0 & & -p -1,-2,-3 & & --title \"my title\" & & -l F,T,F,T -L T,F,T,F & & --cmp 111,222.0,333.0e0,4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( 'x' , x ) call get_args_fixed_size ( 'y' , y ) call get_args_fixed_size ( 'p' , p ) call get_args_fixed_size ( 'title' , title ) call get_args_fixed_size ( 'l' , l ) call get_args_fixed_size ( 'L' , lbig ) call get_args_fixed_size ( 'cmp' , cmp ) ! USE VALUES write ( * , * ) 'x=' , x write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig write ( * , * ) 'cmp=' , cmp end program demo_get_args_fixed_size","tags":"","loc":"sourcefile/demo_get_args_fixed_size.f90.html"}]}
\ No newline at end of file
+var tipuesearch = {"pages":[{"title":" M_CLI2 ","text":"M_CLI2 M_CLI2.f90 and associated files Name M_CLI2 - parse Unix-like command line arguments from Fortran Description M_CLI2(3f) is a Fortran module that will crack the command line when\n given a prototype string that looks very much like an invocation of\n the program. calls are then made for each parameter name to set the\n variables appropriately in the program. Example Program This short program defines a command that can be called using\nconventional Unix-style syntax for short and long parameters: ./show -x 10 -y -20 -p 10 ,20,30 --title \"plot of stuff\" -L\n ./show -lL\n ./show --title = \"my new title\" ./show -T \"my new title\" program show use M_CLI2 , only : set_args , get_args , sget , igets , set_mode implicit none real :: x , y , z logical :: l , lbig integer , allocatable :: p (:) character ( len = :), allocatable :: title namelist / args / x , y , z , l , lbig , p , title ! just for printing call set_mode ( 'strict' ) ! ! Define command and default values and parse supplied command line options call set_args ( '-x 1 -y 2.0 -z 3.5e0 -p 11,-22,33 --title:T \"my title\" -l F -L F' ) ! ! multiple scalar non-allocatable values can be done in one call if desired call get_args ( 'x' , x , 'y' , y , 'z' , z , 'l' , l , 'L' , lbig ) ! you can use convenience functions for allocatable arrays and strings. ! The functions are particularly useful in expressions and as arguments on ! procedure calls title = sget ( 'title' ) ! string p = igets ( 'p' ) ! integer array ! ! All ready to go, print it as a namelist so everything is labeled write ( * , args ) end program show running with no options shows the defaults &ARGS\n X= 1.00000000 ,\n Y= 2.00000000 ,\n Z= 3.50000000 ,\n L=F,\n LBIG=F,\n P=11 ,-22 ,33 ,\n TITLE=\"my title\",\n / An arbitrary number of strings such as filenames may be passed in on\nthe end of commands; you can query whether an option was supplied; and\nget_args(3f)-related routines can be used for refining options such as\nrequiring lists of a specified size. These parameters are defined automatically --help\n --usage\n --version You must supply text for the optional “–help” and “–version” keywords, as\ndescribed under SET_ARGS(3f). Documentation man-pages HTML man-pages index of individual procedures HTML book-form of pages consolidated using JavaScript manpages.zip for installing wherever the man(1) command is available manpages.tgz is an alternative tar(1) format archive developer documentation doxygen(1) output . ford(1) output . logs CHANGELOG STATUS of most recent CI/CD runs Download and Build with Make(1) Compile the M_CLI2 module and build all the example programs. git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2/src # change Makefile if not using one of the listed compilers # for gfortran make clean\n make gfortran # for ifort make clean\n make ifort # for nvfortran make clean\n make nvfortran # display other options (test, run, doxygen, ford, ...) make help To install you then generally copy the .mod file and .a file to\n an appropriate directory. Unfortunately, the specifics vary but in\n general if you have a directory $HOME/.local/lib and copy those files\n there then you can generally enter something like gfortran -L $HOME /.local/lib -lM_CLI2 myprogram.f90 -o myprogram There are different methods for adding the directory to your default\n load path, but frequently you can append the directory you have\n placed the files in into the colon-separated list of directories\n in the $LD_LIBRARY_PATH or $LIBRARY_PATH environment variable, and\n then the -L option will not be required (or it’s equivalent in your\n programming environment). export LD_LIBRARY_PATH = $HOME /.local/lib: $LD_LIBRARY_PATH NOTE : If you use multiple Fortran compilers you may need to create\n a different directory for each compiler. I would recommend it, such\n as $HOME/.local/lib/gfortran/. Creating a shared library If you desire a shared library as well, for gfortran you may enter make clean gfortran gfortran_install and everything needed by gfortran will be placed in libgfortran/ that\n you may add to an appropriate area, such as $HOME/.local/lib/gfortran/. make clean ifort ifort_install # same for ifort does the same for the ifort compiler and places the output in libifort/. Specifics may vary NOTE: The build instructions above are specific to a ULS (Unix-Like\n System) and may differ, especially for those wishing to generate shared\n libraries (which varies significantly depending on the programming\n environment). For some builds it is simpler to make a Makefile for\n each compiler, which might be required for a more comprehensive build\n unless you are very familiar with gmake(1). If you always use one compiler it is relatively simple, otherwise\n make sure you know what your system requires and change the Makefile\n as appropriate. Build with FPM Alternatively, fpm(1) users may download the github repository and build it with\n fpm ( as described at Fortran Package Manager ) git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2\n fpm test # build and test the module fpm install # install the module (in the default location) or just list it as a dependency in your fpm.toml project file. [dependencies] M_CLI2 = { git = \"https://github.com/urbanjost/M_CLI2.git\" } Supports Meson Alternatively, meson(1) users may download the github repository and build it with\n meson ( as described at Meson Build System ) git clone https://github.com/urbanjost/M_CLI2.git cd M_CLI2\n meson setup _build\n meson test -C _build # build and test the module # install the module (in the location) # --destdir is only on newer versions of meson meson install -C _build --destdir # older method if --destdir is not available env DESTDIR = meson install -C _build or just list it as a subproject dependency in your meson.build project file. M_CLI2_dep = subproject ( 'M_CLI2' ). get_variable ( 'M_CLI2_dep' ) Functional Specification This is how the interface works – Pass in a string to set_args(3f) that looks almost like the command\n you would use to execute the program except with all keywords and\n default values specified. you add calls to the get_args(3f) procedure or one of its variants.\n The alternative convenience procedures (rget(3f),sget(3f),iget(3f)\n …) allow you to use a simple function-based interface model. There\n are special routines for when you want to use fixed length. CHARACTER\n variables or fixed-size arrays instead of the allocatable variables\n best used with get_args(3f)). Now when you call the program all the values in the prototype should\n be updated using values from the command line and queried and ready\n to use in your program. Demo Programs These demo programs provide templates for the most common usage: demo3 Example of basic use demo1 Using the convenience functions demo9 Long and short names using –LONGNAME:SHORTNAME. demo2 Putting everything including help and version information into a contained procedure. demo17 Using unnamed options as filenames or strings demo16 Using unnamed values as numbers Optional Modes demo15 Allowing bundling short Boolean keys using “strict” mode demo14 Case-insensitive long keys demo12 Enabling response files demo13 Equivalencing dash to underscore in keynames Niche examples demo8 Parsing multiple keywords in a single call to get_args(3f) demo4 COMPLEX type values demo7 Controlling array delimiter characters demo6 How to create a command with subcommands demo5 extended description of using CHARACTER type values Response files Response files are supported as described in the documentation for set_args .\nThey are a system-independent way to create short abbreviations for long\ncomplex commands. This option is generally not needed by programs with\njust a few options, but can be particularly useful for programs with\ndozens of options where various values are frequently reused. Commit Tests commit 598e44164eee383b8a0775aa75b7d1bb100481c3 was tested on 2020-11-22 with\n + GNU Fortran (GCC) 8.3.1 20191121 (Red Hat 8.3.1-5)\n + ifort (IFORT) 19.1.3.304 20200925\n + nvfortran 20.7-0 LLVM 64-bit target on x86-64 Linux commit 8fe841d8c0c1867f88847e24009a76a98484b31a was tested on 2021-09-29 with\n + GNU Fortran (Ubuntu 10.3.0-1ubuntu1~20.04) 10.3.0\n + ifort (IFORT) 2021.3.0 20210609\n + nvfortran 21.5-0 LLVM 64-bit target on x86-64 Linux -tp nehalem commit 732bcadf95e753ccdf025cec2c08d776ea2534c2 was tested on 2023-02-10 with\n + ifort (IFORT) 2021.8.0 20221119\n + GNU Fortran (Ubuntu 11.1.0-1ubuntu1~20.04) 11.1.0 Last update: Saturday, February 4th, 2023 1:12:54 AM UTC-05:00 Developer Info John S. Urban","tags":"home","loc":"index.html"},{"title":"point – M_CLI2 ","text":"type :: point Contents Variables color x y Source Code point Components Type Visibility Attributes Name Initial character(len=20), public :: color = 'red' integer, public :: x = 0 integer, public :: y = 0 Source Code type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point","tags":"","loc":"type/point.html"},{"title":"cget – M_CLI2","text":"public function cget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex Contents Source Code cget Source Code function cget ( n ); complex :: cget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , cget ); end function cget","tags":"","loc":"proc/cget.html"},{"title":"dget – M_CLI2","text":"public function dget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp) Contents Source Code dget Source Code function dget ( n ); real ( kind = dp ) :: dget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , dget ); end function dget","tags":"","loc":"proc/dget.html"},{"title":"get_subcommand – M_CLI2","text":"public function get_subcommand() result(sub) NAME get_subcommand ( 3 f ) - [ ARGUMENTS : M_CLI2 ] special - case routine for handling subcommands on a command line ( LICENSE : PD ) SYNOPSIS function get_subcommand () character ( len =:), allocatable :: get_subcommand DESCRIPTION In the special case when creating a program with subcommands it\nis assumed the first word on the command line is the subcommand. A\nroutine is required to handle response file processing, therefore\nthis routine (optionally processing response files) returns that\nfirst word as the subcommand name.\n\nIt should not be used by programs not building a more elaborate\ncommand with subcommands. RETURNS NAME name of subcommand EXAMPLE Sample program: program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z --title -l -L !x! demo_get_subcommand test --title -l -L --testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x = - 999.0 , y = - 999.0 , z = - 999.0 character ( len = 80 ) :: title = \"not set\" logical :: l =. false . logical :: l_ =. false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) ! x ! DEFINE AND PARSE COMMAND LINE ! x ! ALL DONE CRACKING THE COMMAND LINE . ! x ! USE THE VALUES IN YOUR PROGRAM . write ( * , * ) ' command was ',name write(*,*)' x , y , z ... . ',x,y,z write ( * , * ) ' title ... . ',title write ( * , * ) ' l , l_ ... .. ',l,l_ write ( * , * ) ' testname . ',testname contains subroutine parse(name) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2, only : set_args, get_args, get_args_fixed_length use M_CLI2, only : get_subcommand, set_mode character(len=*) :: name ! the subcommand name character(len=:),allocatable :: help_text(:), version_text(:) call set_mode(' response_file ' ) ! define version text version_text =[ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text =[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L --title -x -y -z ' , & ' * test -l -L --title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text =[ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , & & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text =[ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( & & '--title \"my title\" -l F -L F --testname \"Test\"' , & & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) ' unknown or missing subcommand [ ',trim(name),' ] ' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments None Return Value character(len=:), allocatable Contents Source Code get_subcommand Source Code function get_subcommand () result ( sub ) ! ident_2=\"@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files\" character ( len = :), allocatable :: sub character ( len = :), allocatable :: cmdarg character ( len = :), allocatable :: array (:) character ( len = :), allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand = '' G_options_only = . true . sub = '' if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif ilongest = longest_command_argument () allocate ( character ( len = max ( 63 , ilongest )) :: cmdarg ) cmdarg (:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( scan ( adjustl ( cmdarg ( 1 : 1 )), '@' ) == 1 ) then call get_prototype ( cmdarg , prototype ) call split ( prototype , array ) ! assume that if using subcommands first word not starting with dash is the subcommand do j = 1 , size ( array ) if ( adjustl ( array ( j )( 1 : 1 )) /= '-' ) then G_subcommand = trim ( array ( j )) sub = G_subcommand exit endif enddo endif enddo if ( G_subcommand /= '' ) then sub = G_subcommand elseif ( size ( unnamed ) /= 0 ) then sub = unnamed ( 1 ) else cmdarg (:) = '' do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( adjustl ( cmdarg ( 1 : 1 )) /= '-' ) then sub = trim ( cmdarg ) exit endif enddo endif G_options_only = . false . end function get_subcommand","tags":"","loc":"proc/get_subcommand.html"},{"title":"iget – M_CLI2","text":"public function iget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer Contents Source Code iget Source Code function iget ( n ); integer :: iget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , iget ); end function iget","tags":"","loc":"proc/iget.html"},{"title":"lget – M_CLI2","text":"public function lget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical Contents Source Code lget Source Code function lget ( n ); logical :: lget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , lget ); end function lget","tags":"","loc":"proc/lget.html"},{"title":"rget – M_CLI2","text":"public function rget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real Contents Source Code rget Source Code function rget ( n ); real :: rget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , rget ); end function rget","tags":"","loc":"proc/rget.html"},{"title":"sget – M_CLI2","text":"public function sget(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value character(len=:), allocatable Contents Source Code sget Source Code function sget ( n ); character ( len = :), allocatable :: sget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , sget ); end function sget","tags":"","loc":"proc/sget.html"},{"title":"specified – M_CLI2","text":"public impure elemental function specified(key) NAME specified ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return true if keyword was present on command line ( LICENSE : PD ) SYNOPSIS elemental impure function specified(name)\n\n character(len=*),intent(in) :: name\n logical :: specified DESCRIPTION specified ( 3 f ) returns . true . if the specified keyword was present on the command line . M_CLI2 intentionally does not have validators except for SPECIFIED ( 3 f ) and of course a check whether the input conforms to the type when requesting a value ( with get_args ( 3 f ) or the convenience functions like inum ( 3 f )) . Fortran already has powerful validation capabilities . Logical expressions ANY ( 3 f ) and ALL ( 3 f ) are standard Fortran features which easily allow performing the common validations for command line arguments without having to learn any additional syntax or methods . OPTIONS NAME name of commandline argument to query the presence of. Long\n names should always be used. RETURNS SPECIFIED returns . TRUE . if specified NAME was present on the command line when the program was invoked . EXAMPLE Sample program: program demo_specified use , intrinsic :: iso_fortran_env , only : & & stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , igets , rgets , specified , sget , lget implicit none ! Define args integer , allocatable :: ints ( : ) real , allocatable :: floats ( : ) logical :: flag character ( len = : ) , allocatable :: color character ( len = : ) , allocatable :: list ( : ) integer :: i call set_args ( ' & & -- color : c \" red \" & & -- flag : f F & & -- ints : i 1 , 10 , 11 & & -- floats : T 12 . 3 , 4 . 56 & & ' ) ints = igets ( ' ints ' ) floats = rgets ( ' floats ' ) flag = lget ( ' flag ' ) color = sget ( ' color ' ) write ( * , * ) ' color= ' , color write ( * , * ) ' flag= ' , flag write ( * , * ) ' ints= ' , ints write ( * , * ) ' floats= ' , floats write ( * , * ) ' was -flag specified? ' , specified ( ' flag ' ) ! elemental write ( * , * ) specified ( [ ' floats ' , ' ints ' ] ) ! If you want to know if groups of parameters were specified use ! ANY ( 3 f ) and ALL ( 3 f ) write ( * , * ) ' ANY: ' , any ( specified ( [ ' floats ' , ' ints ' ] )) write ( * , * ) ' ALL: ' , all ( specified ( [ ' floats ' , ' ints ' ] )) ! For mutually exclusive if ( all ( specified ( [ ' floats ' , ' ints ' ] ))) then write ( * , * ) ' You specified both names --ints and --floats ' endif ! For required parameter if ( . not . any ( specified ( [ ' floats ' , ' ints ' ] ))) then write ( * , * ) ' You must specify --ints or --floats ' endif ! check if all values are in range from 10 to 30 and even write ( * , * ) ' are all numbers good? ' , all ( [ ints >= 10 , ints <= 30 , ( ints / 2 ) * 2 == ints ] ) ! perhaps you want to check one value at a time do i = 1 , size ( ints ) write ( * , * ) ints ( i ) ,[ ints ( i ) >= 10 , ints ( i ) <= 30 , ( ints ( i ) / 2 ) * 2 == ints ( i ) ] if ( all ( [ ints ( i ) >= 10 , ints ( i ) <= 30 , ( ints ( i ) / 2 ) * 2 == ints ( i ) ] ) ) then write ( * , * ) ints ( i ) , ' is an even number from 10 to 30 inclusive ' else write ( * , * ) ints ( i ) , ' is not an even number from 10 to 30 inclusive ' endif enddo list = [ character ( len = 10 ) :: ' red ' , ' white ' , ' blue ' ] if ( any ( color == list ) ) then write ( * , * ) color , ' matches a value in the list ' else write ( * , * ) color , ' not in the list ' endif if ( size ( ints ) . eq . 3 ) then write ( * , * ) ' ints(:) has expected number of values ' else write ( * , * ) ' ints(:) does not have expected number of values ' endif end program demo_specified Default output color=red\nflag= F\nints= 1 10 11\nfloats= 12.3000002 4.55999994\nwas -flag specified? F\nF F\nANY: F\nALL: F\nYou must specify –ints or –floats\n 1 F T F\n 1 is not an even number from 10 to 30 inclusive\n 10 T T T\n 10 is an even number from 10 to 30 inclusive\n 11 T T F\n 11 is not an even number from 10 to 30 inclusive\nred matches a value in the list\nints(:) has expected number of values AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key Return Value logical Contents Source Code specified Source Code elemental impure function specified ( key ) character ( len =* ), intent ( in ) :: key logical :: specified integer :: place call locate_key ( key , place ) ! find where string is or should be if ( place < 1 ) then specified = . false . else specified = present_in ( place ) endif end function specified","tags":"","loc":"proc/specified.html"},{"title":"print_dictionary – M_CLI2","text":"public subroutine print_dictionary(header, stop) NAME print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary\ncreated by calls to set_args(3f)\n(LICENSE:PD) SYNOPSIS subroutine print_dictionary(header,stop)\n\n character(len=*),intent(in),optional :: header\n logical,intent(in),optional :: stop DESCRIPTION Print the internal dictionary created by calls to set_args ( 3 f ) . This routine is intended to print the state of the argument list if an error occurs in using the set_args ( 3 f ) procedure . OPTIONS HEADER label to print before printing the state of the command argument list . STOP logical value that if true stops the program after displaying the dictionary . EXAMPLE Typical usage: program demo_print_dictionary use M_CLI2 , only : set_args , get_args implicit none real :: x , y , z call set_args ( '-x 10 -y 20 -z 30' ) call get_args ( 'x' , x , 'y' , y , 'z' , z ) ! all done cracking the command line ; use the values in your program . write ( * , * ) x , y , z end program demo_print_dictionary Sample output Calling the sample program with an unknown parameter or the -- usage switch produces the following : $ . / demo_print_dictionary - A UNKNOWN SHORT KEYWORD : - A KEYWORD PRESENT VALUE z F [ 3 ] y F [ 2 ] x F [ 1 ] help F [ F ] version F [ F ] usage F [ F ] AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in), optional :: header logical, intent(in), optional :: stop Contents Source Code print_dictionary Source Code subroutine print_dictionary ( header , stop ) character ( len =* ), intent ( in ), optional :: header logical , intent ( in ), optional :: stop integer :: i if ( G_QUIET ) return if ( present ( header )) then if ( header /= '' ) then write ( warn , '(a)' ) header endif endif if ( allocated ( keywords )) then if ( size ( keywords ) > 0 ) then write ( warn , '(a,1x,a,1x,a,1x,a)' ) atleast ( 'KEYWORD' , max ( len ( keywords ), 8 )), 'SHORT' , 'PRESENT' , 'VALUE' write ( warn , '(*(a,1x,a5,1x,l1,8x,\"[\",a,\"]\",/))' ) & & ( atleast ( keywords ( i ), max ( len ( keywords ), 8 )), shorts ( i ), present_in ( i ), values ( i )(: counts ( i )), i = size ( keywords ), 1 , - 1 ) endif endif if ( allocated ( unnamed )) then if ( size ( unnamed ) > 0 ) then write ( warn , '(a)' ) 'UNNAMED' write ( warn , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif endif if ( allocated ( args )) then if ( size ( args ) > 0 ) then write ( warn , '(a)' ) 'ARGS' write ( warn , '(i6.6,3a)' )( i , '[' , args ( i ), ']' , i = 1 , size ( args )) endif endif if ( G_remaining /= '' ) then write ( warn , '(a)' ) 'REMAINING' write ( warn , '(a)' ) G_remaining endif if ( present ( stop )) then if ( stop ) call mystop ( 5 ) endif end subroutine print_dictionary","tags":"","loc":"proc/print_dictionary.html"},{"title":"set_args – M_CLI2","text":"public subroutine set_args(prototype, help_text, version_text, string, prefix, ierr, errmsg) NAME set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing\n(LICENSE:PD) SYNOPSIS subroutine set_args(prototype,help_text,version_text,ierr,errmsg)\n\n character(len=*),intent(in),optional :: prototype\n character(len=*),intent(in),optional :: help_text(:)\n character(len=*),intent(in),optional :: version_text(:)\n integer,intent(out),optional :: ierr\n character(len=:),intent(out),allocatable,optional :: errmsg DESCRIPTION SET_ARGS ( 3 f ) requires a 1 - like command prototype which defines the command - line options and their default values . When the program is executed this and the command - line options are applied and the resulting values are placed in an internal table for retrieval via GET_ARGS ( 3 f ) . The built - in -- help and -- version options require optional help_text and version_text values to be provided to be particularly useful . OPTIONS PROTOTYPE composed of all command arguments concatenated into a Unix - like command prototype string . For example : call set_args ( ' -L F --ints 1,2,3 --title \"my title\" -R 10.3 ' ) The following options are predefined for all commands : ' --verbose F --usage F --help F --version F ' . see \" DEFINING THE PROTOTYPE \" in the next section for further details . HELP_TEXT if present , will be displayed when the program is called with a -- help switch , and then the program will terminate . If help text is not supplied the command line initialization string will be echoed . VERSION_TEXT if present , any version text defined will be displayed when the program is called with a -- version switch , and then the program will terminate . IERR if present a non - zero option is returned when an error occurs instead of the program terminating . ERRMSG a description of the error if ierr is present . DEFINING THE PROTOTYPE o Keywords start with a single dash for short single - character keywords , and with two dashes for longer keywords . o all keywords on the prototype MUST get a value . * logicals must be set to an unquoted F . * strings must be delimited with double - quotes . Since internal double - quotes are represented with two double - quotes the string must be at least one space . o numeric keywords are not allowed ; but this allows negative numbers to be used as values . o lists of values should be comma - delimited unless a user - specified delimiter is used . The prototype must use the same array delimiters as the call to get the value . o to define a zero - length allocatable array make the value a delimiter ( usually a comma ) or an empty set of braces ( \"[]\" ) . LONG AND SHORT NAMES Long keywords start with two dashes followed by more than one letter . Short keywords are a dash followed by a single letter . o It is recommended long names ( -- keyword ) should be all lowercase but are case - sensitive by default , unless \"set_mode('ignorecase')\" is in effect . o Long names should always be more than one character . o The recommended way to have short names is to suffix the long name with : LETTER in the definition . If this syntax is used then logical shorts may be combined on the command line when \"set_mode('strict')\" is in effect . SPECIAL BEHAVIORS o A special behavior occurs if a keyword name ends in :: . When the program is called the next parameter is taken as a value even if it starts with -. This is not generally recommended but is useful in rare cases where non - numeric values starting with a dash are desired . o If the prototype ends with \"--\" a special mode is turned on where anything after \"--\" on input goes into the variable REMAINING with values double - quoted and also into the array ARGS instead of becoming elements in the UNNAMED array . This is not needed for normal processing , but was needed for a program that needed this behavior for its subcommands . That is , for a normal call all unnamed values go into UNNAMED and ARGS and REMAINING are ignored . So for call set_args ( '-x 10 -y 20 ' ) A program invocation such as xx a b c -- A B C \" dd \" results in UNNAMED = [ 'a' , 'b' , 'c' , 'A' , 'B' , 'C' , ' dd' ] REMAINING = '' ARGS = [ character ( len = 0 ) :: ] ! ie , an empty character array Whereas call set_args ( '-x 10 -y 20 --' ) generates the following output from the same program execution : UNNAMED = [ 'a' , 'b' , 'c' ] REMAINING = '\"A\" \"B\" \"C\" \" dd \"' ARGS = [ 'A' , 'B' , 'C,' dd '] USAGE NOTES When invoking the program line note the ( subject to change ) following restrictions ( which often differ between various command - line parsers ): o values for duplicate keywords are appended together with a space separator when a command line is executed by default . o shuffling is not supported . Values immediately follow their keywords . o Only short Boolean keywords can be bundled together . If allowing bundling is desired call \"set_mode('strict')\" . This will require prefixing long names with \"--\" and short names with \"-\" . Otherwise M_CLI2 relaxes that requirement and mostly does not care what prefix is used for a keyword . But this would make it unclear what was meant by \"-ox\" if allowed options were \"-o F -x F --ox F \" for example , so \"strict\" mode is required to remove the ambiguity . o if a parameter value of just \"-\" is supplied it is converted to the string \"stdin\" . o values not needed for a keyword value go into the character array \"UNNAMED\" . In addition if the keyword \"--\" is encountered on the command line the rest of the command line goes into the character array \"UNNAMED\" . EXAMPLE Sample program: program demo_set_args use M_CLI2 , only : filenames => unnamed , set_args , get_args use M_CLI2 , only : get_args_fixed_size implicit none integer :: i ! DEFINE ARGS real :: x , y , z real :: p ( 3 ) character ( len = : ) , allocatable :: title logical :: l , lbig integer , allocatable :: ints ( : ) ! ! DEFINE COMMAND ( TO SET INITIAL VALUES AND ALLOWED KEYWORDS ) ! AND READ COMMAND LINE call set_args ( ' & ! reals & - x 1 - y 2 . 3 - z 3 . 4 e2 & ! integer array & - p - 1 , - 2 , - 3 & ! always double - quote strings & -- title \" my title \" & ! string should be a single character at a minimum & -- label \" \" , & ! set all logical values to F & - l F - L F & ! set allocatable size to zero if you like by using a delimiter & -- ints , & & ' ) ! ASSIGN VALUES TO ELEMENTS ! SCALARS call get_args ( ' x ' , x ) call get_args ( ' y ' , y ) call get_args ( ' z ' , z ) call get_args ( ' l ' , l ) call get_args ( ' L ' , lbig ) call get_args ( ' ints ' , ints ) ! ALLOCATABLE ARRAY call get_args ( ' title ' , title ) ! ALLOCATABLE STRING call get_args_fixed_size ( ' p ' , p ) ! NON - ALLOCATABLE ARRAY ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' y= ' , y write ( * , * ) ' z= ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' ints= ' , ints write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig ! UNNAMED VALUES if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_set_args RESPONSE FILES If you have no interest in using external files as abbreviations\n you can ignore this section. Otherwise, before calling set_args(3f)\n add: use M_CLI2, only : set_mode\n call set_mode('response_file') M_CLI2 Response files are small files containing CLI (Command Line\n Interface) arguments that end with “.rsp” that can be used when command\n lines are so long that they would exceed line length limits or so complex\n that it is useful to have a platform-independent method of creating\n an abbreviation. Shell aliases and scripts are often used for similar purposes (and\n allow for much more complex conditional execution, of course), but\n they generally cannot be used to overcome line length limits and are\n typically platform-specific. Examples of commands that support similar response files are the Clang\n and Intel compilers, although there is no standard format for the files. They are read if you add options of the syntax “@NAME” as the FIRST\n parameters on your program command line calls. They are not recursive –\n that is, an option in a response file cannot be given the value “@NAME2”\n to call another response file. More than one response name may appear on a command line. They are case-sensitive names. Note “@” s a special character in Powershell, and requires being escaped\n with a grave character. LOCATING RESPONSE FILES A search for the response file always starts with the current directory.\n The search then proceeds to look in any additional directories specified\n with the colon-delimited environment variable CLI_RESPONSE_PATH. The first resource file found that results in lines being processed\n will be used and processing stops after that first match is found. If\n no match is found an error occurs and the program is stopped. RESPONSE FILE SECTIONS A simple response file just has options for calling the program in it\n prefixed with the word “options”.\n But they can also contain section headers to denote selections that are\n only executed when a specific OS is being used, print messages, and\n execute system commands. SEARCHING FOR OSTYPE IN REGULAR FILES So assuming the name @NAME was specified on the command line a file\n named NAME.rsp will be searched for in all the search directories\n and then in that file a string that starts with the string @OSTYPE\n (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE\n takes precedence over $OS). SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES Then, the same files will be searched for lines above any line starting\n with “@”. That is, if there is no special section for the current OS\n it just looks at the top of the file for unlabeled options. SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE In addition or instead of files with the same name as the @NAME option\n on the command line, you can have one file named after the executable\n name that contains multiple abbreviation names. So if your program executable is named EXEC you create a single file\n called EXEC.rsp and can append all the simple files described above\n separating them with lines of the form @OSTYPE@NAME or just @NAME. So if no specific file for the abbreviation is found a file called\n “EXEC.rsp” is searched for where “EXEC” is the name of the executable.\n This file is always a “compound” response file that uses the following format: Any compound EXEC.rsp file found in the current or searched directories\n will be searched for the string @OSTYPE@NAME first. Then if nothing is found, the less specific line @NAME is searched for. THE SEARCH IS OVER Sounds complicated but actually works quite intuitively. Make a file in\n the current directory and put options in it and it will be used. If that\n file ends up needing different cases for different platforms add a line\n like “@Linux” to the file and some more lines and that will only be\n executed if the environment variable OSTYPE or OS is “Linux”. If no match\n is found for named sections the lines at the top before any “@” lines\n will be used as a default if no match is found. If you end up using a lot of files like this you can combine them all\n together and put them into a file called “program_name”.rsp and just\n put lines like @NAME or @OSTYPE@NAME at that top of each selection. Now, back to the details on just what you can put in the files. SPECIFICATION FOR RESPONSE FILES SIMPLE RESPONSE FILES The first word of a line is special and has the following meanings: options |- Command options following the rules of the SET_ARGS ( 3 f ) prototype . So o It is preferred to specify a value for all options . o double - quote strings . o give a blank string value as \" \" . o use F | T for lists of logicals , o lists of numbers should be comma - delimited . o -- usage , -- help , -- version , -- verbose , and unknown options are ignored . comment | # Line is a comment line system |! System command . System commands are executed as a simple call to system ( so a cd ( 1 ) or setting a shell variable would not effect subsequent lines , for example ) BEFORE the command being processed . print |> Message to screen stop display message and stop program . NOTE: system commands are executed when encountered, but options are\n gathered from multiple option lines and passed together at the end of\n processing of the block; so all commands will be executed BEFORE the\n command for which options are being supplied no matter where they occur. So if a program that does nothing but echos its parameters program testit use M_CLI2 , only : set_args , rget , sget , lget , set_mode implicit none real :: x , y ; namelist/args/ x,y character ( len = : ) , allocatable :: title ; namelist/args/ title logical :: big ; namelist/args/ big call set_mode ( ' response_file ' ) call set_args ( ' -x 10.0 -y 20.0 --title \"my title\" --big F ' ) x = rget ( ' x ' ) y = rget ( ' y ' ) title = sget ( ' title ' ) big = lget ( ' big ' ) write ( * , nml = args ) end program testit And a file in the current directory called “a.rsp” contains # defaults for project A options - x 1000 - y 9999 options -- title \" \" options -- big T The program could be called with $ myprog # normal call X = 10.0 Y = 20.0 TITLE = \"my title\" $ myprog @a # change defaults as specified in \"a.rsp\" X = 1000.0 Y = 9999.0 TITLE = \" \" # change defaults but use any option as normal to override defaults $ myprog @a - y 1234 X = 1000.0 Y = 1234.0 TITLE = \" \" COMPOUND RESPONSE FILES A compound response file has the same basename as the executable with a\n “.rsp” suffix added. So if your program is named “myprg” the filename\n must be “myprg.rsp”. Note that here `basename` means the last leaf of the name of the program as returned by the Fortran intrinsic GET_COMMAND_ARGUMENT ( 0 ,...) trimmed of anything after a period ( \".\" ), so it is a good idea not to use hidden files . Unlike simple response files compound response files can contain multiple\n setting names. Specifically in a compound file\n if the environment variable $OSTYPE (first) or $OS is set the first search\n will be for a line of the form (no leading spaces should be used): @OSTYPE@alias_name If no match or if the environment variables $OSTYPE and $OS were not\n set or a match is not found then a line of the form @alias_name is searched for in simple or compound files. If found subsequent lines\n will be ignored that start with “@” until a line not starting with\n “@” is encountered. Lines will then be processed until another line\n starting with “@” is found or end-of-file is encountered. COMPOUND RESPONSE FILE EXAMPLE\n An example compound file ################# @ if > RUNNING TESTS USING RELEASE VERSION AND ifort options test -- release -- compiler ifort ################# @ gf > RUNNING TESTS USING RELEASE VERSION AND gfortran options test -- release -- compiler gfortran ################# @ nv > RUNNING TESTS USING RELEASE VERSION AND nvfortran options test -- release -- compiler nvfortran ################# @ nag > RUNNING TESTS USING RELEASE VERSION AND nagfor options test -- release -- compiler nagfor # ################# # OS - specific example : @ Linux @ install # # install executables in directory ( assuming install ( 1 ) exists ) # system mkdir - p ~/ . local / bin options run -- release T -- runner \"install -vbp -m 0711 -t ~/.local/bin\" @ install STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET # ################# @ fpm @ testall # !fpm test --compiler nvfortran !fpm test --compiler ifort !fpm test --compiler gfortran !fpm test --compiler nagfor STOP tests complete. Any additional parameters were ignored ################# Would be used like fpm @install fpm @nag -- fpm @testall NOTES The intel Fortran compiler now calls the response files \"indirect files\" and does not add the implied suffix \".rsp\" to the files anymore . It also allows the @NAME syntax anywhere on the command line , not just at the beginning . -- 20201212 AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: prototype character(len=*), intent(in), optional :: help_text (:) character(len=*), intent(in), optional :: version_text (:) character(len=*), intent(in), optional :: string character(len=*), intent(in), optional :: prefix integer, intent(out), optional :: ierr character(len=:), intent(out), optional, allocatable :: errmsg Contents Source Code set_args Source Code subroutine set_args ( prototype , help_text , version_text , string , prefix , ierr , errmsg ) ! ident_1=\"@(#) M_CLI2 set_args(3f) parse prototype string\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len =* ), intent ( in ), optional :: string character ( len =* ), intent ( in ), optional :: prefix integer , intent ( out ), optional :: ierr character ( len = :), intent ( out ), allocatable , optional :: errmsg character ( len = :), allocatable :: hold ! stores command line argument integer :: ibig character ( len = :), allocatable :: debug_mode debug_mode = upper ( get_env ( 'CLI_DEBUG_MODE' , 'FALSE' )) // ' ' select case ( debug_mode ( 1 : 1 )) case ( 'Y' , 'T' ) G_DEBUG = . true . end select G_response = CLI_RESPONSE_FILE G_options_only = . false . G_passed_in = '' G_STOP = 0 G_STOP_MESSAGE = '' if ( present ( prefix )) then G_PREFIX = prefix else G_PREFIX = '' endif if ( present ( ierr )) then G_QUIET = . true . else G_QUIET = . false . endif ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) call wipe_dictionary () hold = '--version F --usage F --help F --version F ' // adjustl ( prototype ) call prototype_and_cmd_args_to_nlist ( hold , string ) if ( allocated ( G_RESPONSE_IGNORED )) then if ( G_DEBUG ) write ( * , gen ) 'SET_ARGS:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED if ( size ( unnamed ) /= 0 ) write ( * , * ) 'LOGIC ERROR' call split ( G_RESPONSE_IGNORED , unnamed ) endif if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif if (. not . allocated ( args )) then allocate ( character ( len = 0 ) :: args ( 0 )) endif call check_commandline ( help_text , version_text ) ! process --help, --version, --usage if ( present ( ierr )) then ierr = G_STOP endif if ( present ( errmsg )) then errmsg = G_STOP_MESSAGE endif end subroutine set_args","tags":"","loc":"proc/set_args.html"},{"title":"set_mode – M_CLI2","text":"public impure elemental subroutine set_mode(key, mode) NAME set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes\n(LICENSE:PD) SYNOPSIS subroutine set_mode(key,mode)\n\n character(len=*),intent(in) :: key\n logical,intent(in),optional :: mode DESCRIPTION Allow optional behaviors. OPTIONS KEY name of option The following values are allowed : o response_file - enable use of response file o ignorecase - ignore case in long key names . So the user does not have to remember if the option is -- IgnoreCase or -- ignorecase or -- ignoreCase o underdash - treat dash in keyword as an underscore . So the user should not have to remember if the option is -- ignore_case or -- ignore - case . o strict - allow Boolean keys to be bundled , but requires a single dash prefix be used for short key names and long names must be prefixed with two dashes . o lastonly - when multiple keywords occur keep the rightmost value specified instead of appending the values together . MODE set to . true . to activate the optional mode . Set to . false . to deactivate the mode . It is . true . by default . EXAMPLE Sample program: program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ) , parameter :: all = ' (*(g0)) ' ! ! enable use of response files call set_mode ( ' response_file ' ) ! ! Any dash in a keyword is treated as an underscore call set_mode ( ' underdash ' ) ! ! The case of long keywords are ignored . ! Values and short names remain case - sensitive call set_mode ( ' ignorecase ' ) ! ! short single - character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keywords . call set_mode ( ' strict ' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F ' ) ! print all , ' --switch_X or -X ... ' , lget ( ' switch_X ' ) print all , ' --switch_Y or -Y ... ' , lget ( ' switch_Y ' ) print all , ' --ox or -O ... ' , lget ( ' ox ' ) print all , ' -o ... ' , lget ( ' o ' ) print all , ' -x ... ' , lget ( ' x ' ) print all , ' -t ... ' , lget ( ' t ' ) end program demo_set_mode AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key logical, intent(in), optional :: mode Contents Source Code set_mode Source Code elemental impure subroutine set_mode ( key , mode ) character ( len =* ), intent ( in ) :: key logical , intent ( in ), optional :: mode logical :: local_mode if ( present ( mode )) then local_mode = mode else local_mode = . true . endif select case ( lower ( key )) case ( 'response_file' , 'response file' ); CLI_RESPONSE_FILE = local_mode case ( 'debug' ); G_DEBUG = local_mode case ( 'ignorecase' ); G_IGNORECASE = local_mode case ( 'underdash' ); G_UNDERDASH = local_mode case ( 'noseparator' ); G_NOSEPARATOR = local_mode case ( 'strict' ); G_STRICT = local_mode case ( 'lastonly' ); G_APPEND = . not . local_mode case default call journal ( '*set_mode* unknown key name ' , key ) end select if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:END' end subroutine set_mode","tags":"","loc":"proc/set_mode.html"},{"title":"cgets – M_CLI2","text":"public interface cgets Contents Module Procedures cgs cg Module Procedures private function cgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex, allocatable, (:) private function cg() Arguments None Return Value complex, allocatable, (:)","tags":"","loc":"interface/cgets.html"},{"title":"dgets – M_CLI2","text":"public interface dgets Contents Module Procedures dgs dg Module Procedures private function dgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp), allocatable, (:) private function dg() Arguments None Return Value real(kind=dp), allocatable, (:)","tags":"","loc":"interface/dgets.html"},{"title":"get_args – M_CLI2","text":"public interface get_args Contents Module Procedures get_anyarray_d Module Procedures private subroutine get_anyarray_d(keyword, darray, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword real(kind=dp), intent(out), allocatable :: darray (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args.html"},{"title":"get_args_fixed_length – M_CLI2","text":"public interface get_args_fixed_length Contents Module Procedures get_args_fixed_length_a_array Module Procedures private subroutine get_args_fixed_length_a_array(keyword, strings, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword character(len=*), allocatable :: strings (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args_fixed_length.html"},{"title":"get_args_fixed_size – M_CLI2","text":"public interface get_args_fixed_size Contents Module Procedures get_fixedarray_class Module Procedures private subroutine get_fixedarray_class(keyword, generic, delimiters) NAME get_args ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values when parsing command line arguments ( LICENSE : PD ) SYNOPSIS get_args(3f) and its convenience functions: use M_CLI2, only : get_args\n ! convenience functions\n use M_CLI2, only : dget, iget, lget, rget, sget, cget\n use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets\n\n subroutine get_args(name,value,delimiters)\n\n character(len=*),intent(in) :: name\n\n type( ${ TYPE } ),allocatable,intent(out) :: value(:)\n ! or\n type( ${ TYPE } ),allocatable,intent(out) :: value\n\n character(len=*),intent(in),optional :: delimiters\n\n where ${ TYPE } may be from the set\n {real,doubleprecision,integer,logical,complex,character(len=:)} DESCRIPTION GET_ARGS ( 3 f ) returns the value of keywords after SET_ARGS ( 3 f ) has been called to parse the command line . For fixed - length CHARACTER variables see GET_ARGS_FIXED_LENGTH ( 3 f ) . For fixed - size arrays see GET_ARGS_FIXED_SIZE ( 3 f ) . As a convenience multiple pairs of keywords and variables may be specified if and only if all the values are scalars and the CHARACTER variables are fixed - length or pre - allocated . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . The kind of the value is used to determine the type of returned value . May be a scalar or allocatable array . If type is CHARACTER the scalar must have an allocatable length . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . CONVENIENCE FUNCTIONS There are convenience functions that are replacements for calls to get_args ( 3 f ) for each supported default intrinsic type o scalars -- dget ( 3 f ) , iget ( 3 f ) , lget ( 3 f ) , rget ( 3 f ) , sget ( 3 f ) , cget ( 3 f ) o vectors -- dgets ( 3 f ) , igets ( 3 f ) , lgets ( 3 f ) , rgets ( 3 f ) , sgets ( 3 f ) , cgets ( 3 f ) D is for DOUBLEPRECISION , I for INTEGER , L for LOGICAL , R for REAL , S for string ( CHARACTER ) , and C for COMPLEX . If the functions are called with no argument they will return the UNNAMED array converted to the specified type . EXAMPLE Sample program: program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! Define ARGS real :: x , y , z real , allocatable :: p ( : ) character ( len = : ) , allocatable :: title logical :: l , lbig ! Define and parse ( to set initial values ) command line ! o only quote strings and use double - quotes ! o set all logical values to F or T . call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F - L F & & -- label \" \" & & ' ) ! Assign values to elements ! Scalars call get_args ( ' x ' , x , ' y ' , y , ' z ' , z , ' l ' , l , ' L ' , lbig ) ! Allocatable string call get_args ( ' title ' , title ) ! Allocatable arrays call get_args ( ' p ' , p ) ! Use values write ( * , ' (1x,g0,\"=\",g0) ' ) ' x ' , x , ' y ' , y , ' z ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_get_args AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_length ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - length string when parsing command line ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_length(name,value)\n\n character(len=*),intent(in) :: name\n character(len=:),allocatable :: value\n character(len=*),intent(in),optional :: delimiters DESCRIPTION get_args_fixed_length ( 3 f ) returns the value of a string keyword when the string value is a fixed - length CHARACTER variable . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . Must be a fixed - length CHARACTER variable . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! Define args character ( len = 80 ) :: title ! Parse command line call set_args ( ' --title \"my title\" ' ) ! Assign values to variables call get_args_fixed_length ( 'title' , title ) ! Use values write ( * , * ) 'title=' , title end program demo_get_args_fixed_length AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_size ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - size array when parsing command line arguments ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_size(name,value)\n\n character(len=*),intent(in) :: name\n [real|doubleprecision|integer|logical|complex] :: value(NNN)\n or\n character(len=MMM) :: value(NNN)\n\n character(len=*),intent(in),optional :: delimiters DESCRIPTION get_args_fixed_size ( 3 f ) returns the value of keywords for fixed - size arrays after set_args ( 3 f ) has been called . On input on the command line all values of the array must be specified . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned values . The kind of the value is used to determine the type of returned value . Must be a fixed - size array . If type is CHARACTER the length must also be fixed . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0 . 0 d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ) , lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings ! o set all logical values to F or T . call set_args ( ' & & - x 10 . 0 , 20 . 0 & & - y 11 . 0 , 22 . 0 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F , T , F , T - L T , F , T , F & & -- cmp 111 , 222 . 0 , 333 . 0 e0 , 4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( ' x ' , x ) call get_args_fixed_size ( ' y ' , y ) call get_args_fixed_size ( ' p ' , p ) call get_args_fixed_size ( ' title ' , title ) call get_args_fixed_size ( ' l ' , l ) call get_args_fixed_size ( ' L ' , lbig ) call get_args_fixed_size ( ' cmp ' , cmp ) ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig write ( * , * ) ' cmp= ' , cmp end program demo_get_args_fixed_size Results: AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword class(*) :: generic (:) character(len=*), intent(in), optional :: delimiters","tags":"","loc":"interface/get_args_fixed_size.html"},{"title":"igets – M_CLI2","text":"public interface igets Contents Module Procedures igs ig Module Procedures private function igs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer, allocatable, (:) private function ig() Arguments None Return Value integer, allocatable, (:)","tags":"","loc":"interface/igets.html"},{"title":"lgets – M_CLI2","text":"public interface lgets Contents Module Procedures lgs lg Module Procedures private function lgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical, allocatable, (:) private function lg() Arguments None Return Value logical, allocatable, (:)","tags":"","loc":"interface/lgets.html"},{"title":"rgets – M_CLI2","text":"public interface rgets Contents Module Procedures rgs rg Module Procedures private function rgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real, allocatable, (:) private function rg() Arguments None Return Value real, allocatable, (:)","tags":"","loc":"interface/rgets.html"},{"title":"sgets – M_CLI2","text":"public interface sgets Contents Module Procedures sgs sg Module Procedures private function sgs(n, delims) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n character(len=*), intent(in), optional :: delims Return Value character(len=:), allocatable, (:) private function sg() Arguments None Return Value character(len=:), allocatable, (:)","tags":"","loc":"interface/sgets.html"},{"title":"parse – M_CLI2","text":"subroutine parse() Uses M_CLI2 PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY Arguments None Contents Variables cmd help_text version_text Source Code parse Variables Type Visibility Attributes Name Initial character(len=*), public, parameter :: cmd = ' -x 1 -y 2 -z 3 --point -1,-2,-3 --title \"my title\" -l F -L F ' character(len=:), public, allocatable :: help_text (:) DEFINE COMMAND PROTOTYPE\n o All parameters must be listed with a default value\n o string values must be double-quoted\n o numeric lists must be comma-delimited. No spaces are allowed\n o long keynames must be all lowercase character(len=:), public, allocatable :: version_text (:) DEFINE COMMAND PROTOTYPE\n o All parameters must be listed with a default value\n o string values must be double-quoted\n o numeric lists must be comma-delimited. No spaces are allowed\n o long keynames must be all lowercase Source Code subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse","tags":"","loc":"proc/parse.html"},{"title":"parse – M_CLI2","text":"subroutine parse() Uses M_CLI2 Put everything to do with command parsing here DEFINE COMMAND OPTIONS AND DEFAULT VALUES VERSION TEXT (with optional @(#) prefix for what(1) command) Arguments None Contents Source Code parse Source Code subroutine parse () !! Put everything to do with command parsing here !! use M_CLI2 , only : set_args , set_mode call set_mode ([ character ( len = 20 ) :: 'strict' , 'ignorecase' ]) ! a single call to set_args can define the options and their defaults, set help ! text and version information, and crack command line. call set_args (& !! DEFINE COMMAND OPTIONS AND DEFAULT VALUES ' & -i 1 -j 2 -k 3 & -l F -m F -n F & -x 1 -y 2 -z 3 & --title \"my title\" & !! ## HELP TEXT ## ' , [ character ( len = 80 ) :: & !12345678901234567890123456789012345678901234567890123456789012345678901234567890 'NAME ' , & ' myprogram(1) - make all things possible ' , & 'SYNOPSIS ' , & ' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ' , & ' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ' , & 'DESCRIPTION ' , & ' myprogram(1) makes all things possible given stuff. ' , & 'OPTIONS ' , & ' -i,-j,-k some integer values ' , & ' -l,-m,-n some logical values ' , & ' -x,-y,-z some real values ' , & ' --title a string argument ' , & ' FILENAMES any additional strings ' , & 'EXAMPLE ' , & ' Typical usage: ' , & ' ' , & ' demo17 *.* ' , & ' ' , & ' ' , & !! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ## '' ], [ character ( len = 80 ) :: & '@(#)PROGRAM: demo17 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ]) end subroutine parse","tags":"","loc":"proc/parse~2.html"},{"title":"my_run – M_CLI2","text":"subroutine my_run(x, y, z, title, l, l_) Arguments Type Intent Optional Attributes Name real, intent(in) :: x real, intent(in) :: y real, intent(in) :: z character(len=*), intent(in) :: title logical, intent(in) :: l logical, intent(in) :: l_ Contents Source Code my_run Source Code subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run","tags":"","loc":"proc/my_run.html"},{"title":"runit – M_CLI2","text":"subroutine runit(string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Contents Variables cmd Source Code runit Variables Type Visibility Attributes Name Initial character(len=4096), public :: cmd Source Code subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit","tags":"","loc":"proc/runit.html"},{"title":"parse – M_CLI2","text":"subroutine parse(name) Uses M_CLI2 Arguments Type Intent Optional Attributes Name character(len=*) :: name Contents Variables help_text version_text Source Code parse Variables Type Visibility Attributes Name Initial character(len=:), public, allocatable :: help_text (:) character(len=:), public, allocatable :: version_text (:) Source Code subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L --title -x -y -z ' , & ' * test -l -L --title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse","tags":"","loc":"proc/parse~3.html"},{"title":"runit – M_CLI2","text":"subroutine runit(string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Contents Variables cmd Source Code runit Variables Type Visibility Attributes Name Initial character(len=4096), public :: cmd Source Code subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit","tags":"","loc":"proc/runit~2.html"},{"title":"testit – M_CLI2","text":"subroutine testit(string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Contents Source Code testit Source Code subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test if ( test ) then print it , ':syntax:' , string , 'passed' else print it , ':syntax:' , string , 'failed' stop 1 endif end subroutine testit","tags":"","loc":"proc/testit.html"},{"title":"runit – M_CLI2","text":"subroutine runit(string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Contents Variables cmd Source Code runit Variables Type Visibility Attributes Name Initial character(len=4096), public :: cmd Source Code subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit","tags":"","loc":"proc/runit~3.html"},{"title":"testit – M_CLI2","text":"subroutine testit(string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Contents Source Code testit Source Code subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':lastonly:' , string , 'passed' else print it , ':lastonly:' , string , 'failed' stop 1 endif end subroutine testit","tags":"","loc":"proc/testit~2.html"},{"title":"runit – M_CLI2","text":"subroutine runit(string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Contents Variables cmd Source Code runit Variables Type Visibility Attributes Name Initial character(len=4096), public :: cmd Source Code subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit","tags":"","loc":"proc/runit~4.html"},{"title":"testit – M_CLI2","text":"subroutine testit(string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Contents Source Code testit Source Code subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':ignorecase:' , string , 'passed' else print it , ':ignorecase:' , string , 'failed' stop 1 endif end subroutine testit","tags":"","loc":"proc/testit~3.html"},{"title":"runit – M_CLI2","text":"subroutine runit(string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Contents Variables cmd Source Code runit Variables Type Visibility Attributes Name Initial character(len=4096), public :: cmd Source Code subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit","tags":"","loc":"proc/runit~5.html"},{"title":"testit – M_CLI2","text":"subroutine testit(string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Contents Source Code testit Source Code subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':strict:' , string , 'passed' else print it , ':strict:' , string , 'failed' stop 1 endif end subroutine testit","tags":"","loc":"proc/testit~4.html"},{"title":"M_CLI2 – M_CLI2","text":"NAME M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument\nparsing using a prototype command\n(LICENSE:PD) SYNOPSIS Available procedures and variables: ! basic procedures use M_CLI2 , only : set_args , get_args , specified , set_mode ! convenience functions use M_CLI2 , only : dget , iget , lget , rget , sget , cget use M_CLI2 , only : dgets , igets , lgets , rgets , sgets , cgets ! variables use M_CLI2 , only : unnamed , remaining , args ! working with non - allocatable strings and arrays use M_CLI2 , only : get_args_fixed_length , get_args_fixed_size ! special function for creating subcommands use M_CLI2 , only : get_subcommand ( 3 f ) DESCRIPTION The M_CLI2 module cracks a Unix - style command line . Typically one call to SET_ARGS ( 3 f ) is made to define the command arguments , set default values and parse the command line . Then a call is made to the convenience procedures or GET_ARGS ( 3 f ) proper for each command keyword to obtain the argument values . Detailed descriptions of each procedure and example programs are included . EXAMPLE Sample minimal program which may be called in various ways: mimimal -x 100.3 -y 3.0e4\n mimimal --xvalue=300 --debug\n mimimal --yvalue 400\n mimimal -x 10 file1 file2 file3 Program example: program minimal use M_CLI2 , only : set_args , lget , rget , sgets implicit none real :: x , y integer :: i character ( len = : ) , allocatable :: filenames ( : ) ! define and crack command line call set_args ( ' --yvalue:y 0.0 --xvalue:x 0.0 --debug F ' ) ! get values x = rget ( ' xvalue ' ) y = rget ( ' yvalue ' ) if ( lget ( ' debug ' )) then write ( * , * ) ' X= ' , x write ( * , * ) ' Y= ' , y write ( * , * ) ' ATAN2(Y,X)= ' , atan2 ( x = x , y = y ) else write ( * , * ) atan2 ( x = x , y = y ) endif filenames = sgets () ! sget with no name gets \" unnamed \" values if ( size ( filenames ) > 0 ) then write ( * , ' (g0) ' ) ' filenames: ' write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program minimal Sample program using get_args() and variants program demo_M_CLI2 use M_CLI2 , only : set_args , get_args use M_CLI2 , only : filenames => unnamed use M_CLI2 , only : get_args_fixed_length , get_args_fixed_size implicit none integer :: i integer , parameter :: dp = kind ( 0.0 d0 ) ! ! Define ARGS real :: x , y , z logical :: l , lbig character ( len = 40 ) :: label ! FIXED LENGTH real ( kind = dp ), allocatable :: point (:) logical , allocatable :: logicals (:) character ( len = :), allocatable :: title ! VARIABLE LENGTH real :: p ( 3 ) ! FIXED SIZE logical :: logi ( 3 ) ! FIXED SIZE ! ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o set a value for all keywords . ! o double - quote strings , strings must be at least one space ! because adjacent double - quotes designate a double - quote ! in the value . ! o set all logical values to F ! o numeric values support an \"e\" or \"E\" exponent ! o for lists delimit with a comma , colon , or space call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 - 2 - 3 & & -- point 11.11 , 22.22 , 33.33e0 & & -- title \"my title\" - l F - L F & & -- logicals F F F F F & & -- logi F T F & & -- label \" \" & ! note space between quotes is required & ') ! Assign values to elements using G_ARGS ( 3 f ) . ! non - allocatable scalars can be done up to twenty per call call get_args ( 'x' , x , 'y' , y , 'z' , z , 'l' , l , 'L' , lbig ) ! As a convenience multiple pairs of keywords and variables may be ! specified if and only if all the values are scalars and the CHARACTER ! variables are fixed - length or pre - allocated . ! ! After SET_ARGS ( 3 f ) has parsed the command line ! GET_ARGS ( 3 f ) retrieves the value of keywords accept for ! two special cases . For fixed - length CHARACTER variables ! see GET_ARGS_FIXED_LENGTH ( 3 f ) . For fixed - size arrays see ! GET_ARGS_FIXED_SIZE ( 3 f ) . ! ! allocatables should be done one at a time call get_args ( 'title' , title ) ! allocatable string call get_args ( 'point' , point ) ! allocatable arrays call get_args ( 'logicals' , logicals ) ! ! less commonly ... ! for fixed - length strings call get_args_fixed_length ( 'label' , label ) ! for non - allocatable arrays call get_args_fixed_size ( 'p' , p ) call get_args_fixed_size ( 'logi' , logi ) ! ! all done parsing , use values write ( * , * ) 'x=' , x , 'y=' , y , 'z=' , z , x + y + z write ( * , * ) 'p=' , p write ( * , * ) 'point=' , point write ( * , * ) 'title=' , title write ( * , * ) 'label=' , label write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig write ( * , * ) 'logicals=' , logicals write ( * , * ) 'logi=' , logi ! ! unnamed strings ! if ( size ( filenames ) > 0 ) then write ( * , '(i6.6,3a)' )( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) endif ! end program demo_M_CLI2 AUTHOR John S. Urban, 2019 LICENSE Public Domain SEE ALSO + get_args(3f)\n + get_args_fixed_size(3f)\n + get_args_fixed_length(3f)\n + get_subcommand(3f)\n + set_mode(3f)\n + specified(3f) Note that the convenience routines are described under get_args(3f):\n dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),\n igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f) Uses iso_fortran_env Contents Variables CLI_RESPONSE_FILE args remaining unnamed Interfaces cgets dgets get_args get_args_fixed_length get_args_fixed_size igets lgets rgets sgets Functions cget dget get_subcommand iget lget rget sget specified Subroutines print_dictionary set_args set_mode Variables Type Visibility Attributes Name Initial logical, public, save :: CLI_RESPONSE_FILE = .false. character(len=:), public, allocatable :: args (:) character(len=:), public, allocatable :: remaining character(len=:), public, allocatable :: unnamed (:) Interfaces public interface cgets private function cgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex, allocatable, (:) private function cg() Arguments None Return Value complex, allocatable, (:) public interface dgets private function dgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp), allocatable, (:) private function dg() Arguments None Return Value real(kind=dp), allocatable, (:) public interface get_args private subroutine get_anyarray_d(keyword, darray, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword real(kind=dp), intent(out), allocatable :: darray (:) character(len=*), intent(in), optional :: delimiters public interface get_args_fixed_length private subroutine get_args_fixed_length_a_array(keyword, strings, delimiters) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword character(len=*), allocatable :: strings (:) character(len=*), intent(in), optional :: delimiters public interface get_args_fixed_size private subroutine get_fixedarray_class(keyword, generic, delimiters) NAME get_args ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values when parsing command line arguments ( LICENSE : PD ) SYNOPSIS get_args(3f) and its convenience functions: use M_CLI2, only : get_args\n ! convenience functions\n use M_CLI2, only : dget, iget, lget, rget, sget, cget\n use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets\n\n subroutine get_args(name,value,delimiters)\n\n character(len=*),intent(in) :: name\n\n type( ${ TYPE } ),allocatable,intent(out) :: value(:)\n ! or\n type( ${ TYPE } ),allocatable,intent(out) :: value\n\n character(len=*),intent(in),optional :: delimiters\n\n where ${ TYPE } may be from the set\n {real,doubleprecision,integer,logical,complex,character(len=:)} DESCRIPTION GET_ARGS ( 3 f ) returns the value of keywords after SET_ARGS ( 3 f ) has been called to parse the command line . For fixed - length CHARACTER variables see GET_ARGS_FIXED_LENGTH ( 3 f ) . For fixed - size arrays see GET_ARGS_FIXED_SIZE ( 3 f ) . As a convenience multiple pairs of keywords and variables may be specified if and only if all the values are scalars and the CHARACTER variables are fixed - length or pre - allocated . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . The kind of the value is used to determine the type of returned value . May be a scalar or allocatable array . If type is CHARACTER the scalar must have an allocatable length . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . CONVENIENCE FUNCTIONS There are convenience functions that are replacements for calls to get_args ( 3 f ) for each supported default intrinsic type o scalars -- dget ( 3 f ) , iget ( 3 f ) , lget ( 3 f ) , rget ( 3 f ) , sget ( 3 f ) , cget ( 3 f ) o vectors -- dgets ( 3 f ) , igets ( 3 f ) , lgets ( 3 f ) , rgets ( 3 f ) , sgets ( 3 f ) , cgets ( 3 f ) D is for DOUBLEPRECISION , I for INTEGER , L for LOGICAL , R for REAL , S for string ( CHARACTER ) , and C for COMPLEX . If the functions are called with no argument they will return the UNNAMED array converted to the specified type . EXAMPLE Sample program: program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! Define ARGS real :: x , y , z real , allocatable :: p ( : ) character ( len = : ) , allocatable :: title logical :: l , lbig ! Define and parse ( to set initial values ) command line ! o only quote strings and use double - quotes ! o set all logical values to F or T . call set_args ( ' & & - x 1 - y 2 - z 3 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F - L F & & -- label \" \" & & ' ) ! Assign values to elements ! Scalars call get_args ( ' x ' , x , ' y ' , y , ' z ' , z , ' l ' , l , ' L ' , lbig ) ! Allocatable string call get_args ( ' title ' , title ) ! Allocatable arrays call get_args ( ' p ' , p ) ! Use values write ( * , ' (1x,g0,\"=\",g0) ' ) ' x ' , x , ' y ' , y , ' z ' , z write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig if ( size ( filenames ) > 0 ) then write ( * , ' (i6.6,3a) ' )( i , ' [ ' , filenames ( i ) , ' ] ' , i = 1 , size ( filenames )) endif end program demo_get_args AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_length ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - length string when parsing command line ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_length(name,value)\n\n character(len=*),intent(in) :: name\n character(len=:),allocatable :: value\n character(len=*),intent(in),optional :: delimiters DESCRIPTION get_args_fixed_length ( 3 f ) returns the value of a string keyword when the string value is a fixed - length CHARACTER variable . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned value . Must be a fixed - length CHARACTER variable . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! Define args character ( len = 80 ) :: title ! Parse command line call set_args ( ' --title \"my title\" ' ) ! Assign values to variables call get_args_fixed_length ( 'title' , title ) ! Use values write ( * , * ) 'title=' , title end program demo_get_args_fixed_length AUTHOR John S. Urban, 2019 LICENSE Public Domain NAME get_args_fixed_size ( 3 f ) - [ ARGUMENTS : M_CLI2 ] return keyword values for fixed - size array when parsing command line arguments ( LICENSE : PD ) SYNOPSIS subroutine get_args_fixed_size(name,value)\n\n character(len=*),intent(in) :: name\n [real|doubleprecision|integer|logical|complex] :: value(NNN)\n or\n character(len=MMM) :: value(NNN)\n\n character(len=*),intent(in),optional :: delimiters DESCRIPTION get_args_fixed_size ( 3 f ) returns the value of keywords for fixed - size arrays after set_args ( 3 f ) has been called . On input on the command line all values of the array must be specified . OPTIONS NAME name of commandline argument to obtain the value of VALUE variable to hold returned values . The kind of the value is used to determine the type of returned value . Must be a fixed - size array . If type is CHARACTER the length must also be fixed . DELIMITERS By default the delimiter for array values are comma , colon , and whitespace . A string containing an alternate list of delimiter characters may be supplied . EXAMPLE Sample program: program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0 . 0 d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ) , lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE ( TO SET INITIAL VALUES ) COMMAND LINE ! o only quote strings ! o set all logical values to F or T . call set_args ( ' & & - x 10 . 0 , 20 . 0 & & - y 11 . 0 , 22 . 0 & & - p - 1 , - 2 , - 3 & & -- title \" my title \" & & - l F , T , F , T - L T , F , T , F & & -- cmp 111 , 222 . 0 , 333 . 0 e0 , 4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( ' x ' , x ) call get_args_fixed_size ( ' y ' , y ) call get_args_fixed_size ( ' p ' , p ) call get_args_fixed_size ( ' title ' , title ) call get_args_fixed_size ( ' l ' , l ) call get_args_fixed_size ( ' L ' , lbig ) call get_args_fixed_size ( ' cmp ' , cmp ) ! USE VALUES write ( * , * ) ' x= ' , x write ( * , * ) ' p= ' , p write ( * , * ) ' title= ' , title write ( * , * ) ' l= ' , l write ( * , * ) ' L= ' , lbig write ( * , * ) ' cmp= ' , cmp end program demo_get_args_fixed_size Results: AUTHOR John S. Urban, 2019 LICENSE Public Domain Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: keyword class(*) :: generic (:) character(len=*), intent(in), optional :: delimiters public interface igets private function igs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer, allocatable, (:) private function ig() Arguments None Return Value integer, allocatable, (:) public interface lgets private function lgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical, allocatable, (:) private function lg() Arguments None Return Value logical, allocatable, (:) public interface rgets private function rgs(n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real, allocatable, (:) private function rg() Arguments None Return Value real, allocatable, (:) public interface sgets private function sgs(n, delims) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n character(len=*), intent(in), optional :: delims Return Value character(len=:), allocatable, (:) private function sg() Arguments None Return Value character(len=:), allocatable, (:) Functions public function cget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value complex public function dget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real(kind=dp) public function get_subcommand () result(sub) Sample program: Read more… Arguments None Return Value character(len=:), allocatable public function iget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value integer public function lget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value logical public function rget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value real public function sget (n) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: n Return Value character(len=:), allocatable public impure elemental function specified (key) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key Return Value logical Subroutines public subroutine print_dictionary (header, stop) Typical usage: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in), optional :: header logical, intent(in), optional :: stop public subroutine set_args (prototype, help_text, version_text, string, prefix, ierr, errmsg) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: prototype character(len=*), intent(in), optional :: help_text (:) character(len=*), intent(in), optional :: version_text (:) character(len=*), intent(in), optional :: string character(len=*), intent(in), optional :: prefix integer, intent(out), optional :: ierr character(len=:), intent(out), optional, allocatable :: errmsg public impure elemental subroutine set_mode (key, mode) Sample program: Read more… Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: key logical, intent(in), optional :: mode","tags":"","loc":"module/m_cli2.html"},{"title":"demo3 – M_CLI2","text":"Uses M_CLI2 example of basic use\n! JUST THE BARE ESSENTIALS Contents Variables l size title x y Source Code demo3 Variables Type Attributes Name Initial logical :: l real :: size character(len=:), allocatable :: title integer :: x integer :: y Source Code program demo3 !! example of **basic** use !*! JUST THE BARE ESSENTIALS use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size:s 12.34567 -l F --title:t \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"program/demo3.html"},{"title":"minimal – M_CLI2","text":"Uses M_CLI2 Contents Variables filenames i ints x y Source Code minimal Variables Type Attributes Name Initial character(len=:), allocatable :: filenames (:) integer :: i integer, allocatable :: ints (:) real :: x real :: y Source Code program minimal use M_CLI2 , only : set_args , lget , rget , sgets , igets , set_mode implicit none real :: x , y integer :: i integer , allocatable :: ints (:) character ( len = :), allocatable :: filenames (:) ! define and crack command line !call set_mode('debug') call set_args ( ' --yvalue:y 0.0 --xvalue:x 0.0 --ints [] --debug F' ) ! get values write ( * , * ) 'INTS=' , igets ( 'ints' ) x = rget ( 'xvalue' ) y = rget ( 'yvalue' ) if ( lget ( 'debug' )) then write ( * , * ) 'X=' , x write ( * , * ) 'Y=' , y write ( * , * ) 'ATAN2(Y,X)=' , atan2 ( x = x , y = y ) else write ( * , * ) atan2 ( x = x , y = y ) end if filenames = sgets () ! sget with no name gets \"unnamed\" values if ( size ( filenames ) > 0 ) then write ( * , '(g0)' ) 'filenames:' write ( * , '(i6.6,3a)' ) ( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) end if end program minimal","tags":"","loc":"program/minimal.html"},{"title":"demo2 – M_CLI2","text":"Uses M_CLI2 @(#) all parsing and help and version information in a contained procedure.\nDEFINE AND PARSE COMMAND LINE ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM.\nTHE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE\nACCUMULATED IN THE CHARACTER ARRAY “UNNAMED” Contents Variables i l l_ point title x y z Subroutines parse Source Code demo2 Variables Type Attributes Name Initial integer :: i DEFINE “ARGS” VALUES logical :: l logical :: l_ real :: point (3) character(len=80) :: title integer :: x integer :: y integer :: z Subroutines subroutine parse () PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY Arguments None Source Code program demo2 !! @(#) all parsing and **help** and **version** information in a contained procedure. use M_CLI2 , only : unnamed implicit none integer :: i !! DEFINE \"ARGS\" VALUES integer :: x , y , z real :: point ( 3 ) character ( len = 80 ) :: title logical :: l , l_ print * , 'demo2: all parsing and **help** and **version** information in a contained procedure' call parse () !! DEFINE AND PARSE COMMAND LINE !! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM. write ( * , * ) x + y + z write ( * , * ) point * 2 write ( * , * ) title write ( * , * ) l , l_ !! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE !! ACCUMULATED IN THE CHARACTER ARRAY \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif contains subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse end program demo2","tags":"","loc":"program/demo2.html"},{"title":"demo12 – M_CLI2","text":"Uses M_CLI2 @(#) using the convenience functions\nENABLE USING RESPONSE FILES\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables x y z Source Code demo12 Variables Type Attributes Name Initial real :: x real :: y real :: z Source Code program demo12 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , rget implicit none real :: x , y , z print * , 'demo12: using the convenience functions' !! ENABLE USING RESPONSE FILES call set_mode ( 'response file' ) call set_args ( '-x 1.1 -y 2e3 -z -3.9 ' ) x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z end program demo12","tags":"","loc":"program/demo12.html"},{"title":"demo3 – M_CLI2","text":"Uses M_CLI2 @(#) example of basic use using just the bare essentials Contents Variables l size title x y Source Code demo3 Variables Type Attributes Name Initial logical :: l real :: size character(len=:), allocatable :: title integer :: x integer :: y Source Code program demo3 !! @(#) example of **basic** use using just the bare essentials use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title print * , 'demo3: just the bare essentials' ! define the command, set default values and read the command line call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! get the values call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! do allocatables one at a time ! Done. All variables set and of the requested type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"program/demo3~2.html"},{"title":"demo17 – M_CLI2","text":"Uses M_CLI2 @(#) using the unnamed parameters as filenames\n For example, this should list the files in the current directory demo17 * Also demonstrates setting –help and –version text. demo17 --help\ndemo17 --version\ndemo17 --usage Define and parse command line\nGet argument values \nAll done cracking the command line use the values in your program.\nThe optional unnamed values on the command line are\naccumulated in the character array “UNNAMED” which was \nrenamed to “FILENAMES” on the use statement Contents Variables all fnames i indx j k l m n title x y z Subroutines parse Source Code demo17 Variables Type Attributes Name Initial type(character(len=*)), parameter :: all = '(*(g0))' type(character(len=:)), allocatable :: fnames (:) type(integer) :: i type(integer) :: indx argument values to set type(integer) :: j type(integer) :: k type(logical) :: l type(logical) :: m type(logical) :: n type(character(len=:)), allocatable :: title type(real) :: x type(real) :: y type(real) :: z Subroutines subroutine parse () Put everything to do with command parsing here Read more… Arguments None Source Code program demo17 !! @(#) using the unnamed parameters as filenames !! For example, this should list the files in the current directory !! !! demo17 * !! !! Also demonstrates setting --help and --version text. !! !! demo17 --help !! demo17 --version !! demo17 --usage !! use M_CLI2 , only : get_args use M_CLI2 , only : sget , lget , iget , rget , dget , cget use M_CLI2 , only : sgets , lgets , igets , rgets , dgets , cgets use M_CLI2 , only : filenames => unnamed implicit none type ( character ( len =* )), parameter :: all = '(*(g0))' type ( integer ) :: indx !! argument values to set type ( integer ) :: i , j , k type ( real ) :: x , y , z type ( character ( len = :)), allocatable :: title type ( logical ) :: l , m , n type ( character ( len = :)), allocatable :: fnames (:) print all , 'demo17: using the unnamed parameters as filenames' print all , 'example: demo17 -x 100 * ' call parse () !! Define and parse command line !! Get argument values call get_args ( 'x' , x , 'y' , y , 'z' , z ) call get_args ( 'i' , i , 'j' , j , 'k' , k ) call get_args ( 'l' , l , 'm' , m , 'n' , n ) title = sget ( 'title' ) !! All done cracking the command line use the values in your program. print all , 'x=' , x , ' y=' , y , ' z=' , z print all , 'i=' , i , ' j=' , j , ' k=' , k print all , 'l=' , l , ' m=' , m , ' n=' , n print all , 'title=' , title !! The optional unnamed values on the command line are !! accumulated in the character array \"UNNAMED\" which was !! renamed to \"FILENAMES\" on the use statement if ( allocated ( filenames )) then if ( size ( filenames ) > 0 ) then print all , 'files:' print '(i6.6,1x,3a)' ,( indx , '[' , filenames ( indx ), ']' , indx = 1 , size ( filenames )) endif endif ! alternate method, additionally can be used when desired result is numeric ! by using igets(3f), rgets(3f), ... instead of sgets(3f). fnames = sgets () ! also gets all the unnamed arguments if ( size ( fnames ) > 0 ) then print all , 'files:' print '(i6.6,1x,3a)' ,( indx , '[' , fnames ( indx ), ']' , indx = 1 , size ( fnames )) endif contains subroutine parse () !! Put everything to do with command parsing here !! use M_CLI2 , only : set_args , set_mode call set_mode ([ character ( len = 20 ) :: 'strict' , 'ignorecase' ]) ! a single call to set_args can define the options and their defaults, set help ! text and version information, and crack command line. call set_args (& !! DEFINE COMMAND OPTIONS AND DEFAULT VALUES ' & -i 1 -j 2 -k 3 & -l F -m F -n F & -x 1 -y 2 -z 3 & --title \"my title\" & !! ## HELP TEXT ## ' , [ character ( len = 80 ) :: & !12345678901234567890123456789012345678901234567890123456789012345678901234567890 'NAME ' , & ' myprogram(1) - make all things possible ' , & 'SYNOPSIS ' , & ' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ' , & ' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ' , & 'DESCRIPTION ' , & ' myprogram(1) makes all things possible given stuff. ' , & 'OPTIONS ' , & ' -i,-j,-k some integer values ' , & ' -l,-m,-n some logical values ' , & ' -x,-y,-z some real values ' , & ' --title a string argument ' , & ' FILENAMES any additional strings ' , & 'EXAMPLE ' , & ' Typical usage: ' , & ' ' , & ' demo17 *.* ' , & ' ' , & ' ' , & !! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ## '' ], [ character ( len = 80 ) :: & '@(#)PROGRAM: demo17 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ]) end subroutine parse end program demo17","tags":"","loc":"program/demo17.html"},{"title":"demo9 – M_CLI2","text":"Uses M_CLI2 @(#) long and short names using –LONGNAME:SHORTNAME When all keys have a long and short name and “strict mode” is invoked\n where “-” is required for short names and “–” for long names Boolean\n values may be bundled together. For example: demo9 -XYZ Contents Variables all Source Code demo9 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo9 !> @(#) long and short names using --LONGNAME:SHORTNAME !! !! When all keys have a long and short name and \"strict mode\" is invoked !! where \"-\" is required for short names and \"--\" for long names Boolean !! values may be bundled together. For example: !! !! demo9 -XYZ !! use M_CLI2 , only : set_args , sget , rget , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo9: long and short names using --LONGNAME:SHORTNAME' !call set_mode('strict') call set_args ( ' & & --length:l 10 & & --height:h 12.45 & & --switchX:X F & & --switchY:Y F & & --switchZ:Z F & & --title:T \"my title\"' ) print all , '--length or -l .... ' , rget ( 'length' ) print all , '--height or -h .... ' , rget ( 'height' ) print all , '--switchX or -X ... ' , lget ( 'switchX' ) print all , '--switchY or -Y ... ' , lget ( 'switchY' ) print all , '--switchZ or -Z ... ' , lget ( 'switchZ' ) print all , '--title or -T ..... ' , sget ( 'title' ) end program demo9","tags":"","loc":"program/demo9.html"},{"title":"demo15 – M_CLI2","text":"Uses M_CLI2 @(#) strict mode In strict mode short single-character names may be bundled but it is\nrequired that a single dash is used, where normally single and double\ndashes are equivalent. demo15 -o -t -x\ndemo15 -otx\ndemo15 -xto Only Boolean keynames may be bundled together Contents Variables all Source Code demo15 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo15 !> @(#) strict mode !! !! In strict mode short single-character names may be bundled but it is !! required that a single dash is used, where normally single and double !! dashes are equivalent. !! !! demo15 -o -t -x !! demo15 -otx !! demo15 -xto !! !! Only Boolean keynames may be bundled together !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo15: strict mode' call set_mode ( 'strict' ) call set_args ( ' -o F -t F -x F --ox F' ) print all , 'o=' , lget ( 'o' ), ' t=' , lget ( 't' ), ' x=' , lget ( 'x' ), ' ox=' , lget ( 'ox' ) end program demo15","tags":"","loc":"program/demo15.html"},{"title":"demo6 – M_CLI2","text":"Uses M_CLI2 @(#) SUBCOMMANDS For a command with subcommands like git(1) you can call this program\nwhich has two subcommands (run, test), like this: demo6 –help\n demo6 run -x -y -z -title -l -L\n demo6 test -title -l -L -testname\n demo6 run –help Contents Variables help_text l l_ name testname title version_text Subroutines my_run Source Code demo6 Variables Type Attributes Name Initial character(len=:), allocatable :: help_text (:) logical :: l logical :: l_ character(len=:), allocatable :: name character(len=80) :: testname character(len=80) :: title character(len=:), allocatable :: version_text (:) Subroutines subroutine my_run (x, y, z, title, l, l_) Arguments Type Intent Optional Attributes Name real, intent(in) :: x real, intent(in) :: y real, intent(in) :: z character(len=*), intent(in) :: title logical, intent(in) :: l logical, intent(in) :: l_ Source Code program demo6 !! @(#) SUBCOMMANDS !! !! For a command with subcommands like git(1) you can call this program !! which has two subcommands (run, test), like this: !! !! demo6 --help !! demo6 run -x -y -z -title -l -L !! demo6 test -title -l -L -testname !! demo6 run --help !! use M_CLI2 , only : set_args , get_args , get_args_fixed_length , get_subcommand use M_CLI2 , only : rget , sget , lget use M_CLI2 , only : CLI_RESPONSE_FILE implicit none character ( len = :), allocatable :: name ! the subcommand name character ( len = :), allocatable :: version_text (:), help_text (:) ! define some values to use as arguments character ( len = 80 ) :: title , testname logical :: l , l_ print * , 'demo6: creating subcommands' version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo6 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] CLI_RESPONSE_FILE = . true . ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () ! define commands and parse command line and set help text and process command select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , help_text , version_text ) ! example using convenience functions to retrieve values and pass them ! to a routine call my_run ( rget ( 'x' ), rget ( 'y' ), rget ( 'z' ), sget ( 'title' ), lget ( 'l' ), lget ( 'L' )) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( '--title \"my title\" -l F -L F --testname \"Test\"' , help_text , version_text ) ! use get_args(3f) to extract values and use them call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) ! all done cracking the command line. use the values in your program. write ( * , * ) 'command was ' , name write ( * , * ) 'title .... ' , trim ( title ) write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , trim ( testname ) case ( '' ) ! general help for \"demo6 --help\" help_text = [ character ( len = 80 ) :: & ' General help describing the ' , & ' program. ' , & '' ] call set_args ( ' ' , help_text , version_text ) ! process help and version case default call set_args ( ' ' , help_text , version_text ) ! process help and version write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' end select contains subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run end program demo6","tags":"","loc":"program/demo6.html"},{"title":"demo5 – M_CLI2","text":"Uses M_CLI2 @(#) CHARACTER type values\ncharacter variables have a length, unlike number variables Contents Variables fmt Source Code demo5 Variables Type Attributes Name Initial character(len=*), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' Source Code program demo5 !! @(#) _CHARACTER_ type values !! character variables have a length, unlike number variables use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : sget , sgets implicit none character ( len =* ), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' print * , 'demo5: CHARACTER argument examples' call set_args ( ' & & --alloc_len_scalar \" \" & & --fx_len_scalar \" \" & & --alloc_array \"A,B,C\" & & --fx_size_fx_len \"A,B,C\" & & --fx_len_alloc_array \"A,B,C\" & & ' ) block ! you just need get_args(3f) for general scalars or arrays ! variable length scalar character ( len = :), allocatable :: alloc_len_scalar ! variable array size and variable length character ( len = :), allocatable :: alloc_array (:) call get_args ( 'alloc_len_scalar' , alloc_len_scalar ) write ( * , fmt ) 'allocatable length scalar=' , alloc_len_scalar ,& & len ( alloc_len_scalar ) call get_args ( 'alloc_array' , alloc_array ) write ( * , fmt ) 'allocatable array= ' , alloc_array endblock ! less commonly, if length or size is fixed, use a special function block character ( len = 19 ), allocatable :: fx_len_alloc_array (:) call get_args_fixed_length ( 'fx_len_alloc_array' , fx_len_alloc_array ) write ( * , fmt ) 'fixed length allocatable array=' , fx_len_alloc_array endblock block character ( len = 19 ) :: fx_len_scalar call get_args_fixed_length ( 'fx_len_scalar' , fx_len_scalar ) write ( * , fmt ) 'fixed length scalar= ' , fx_len_scalar endblock block character ( len = 19 ) :: fx_size_fx_len ( 3 ) call get_args_fixed_size ( 'fx_size_fx_len' , fx_size_fx_len ) write ( * , fmt ) 'fixed size fixed length= ' , fx_size_fx_len endblock block ! or (recommended) set to an allocatable array and check size and ! length returned character ( len = :), allocatable :: a ! variable length scalar character ( len = :), allocatable :: arr (:) ! variable array size and variable length call get_args ( 'fx_size_fx_len' , arr ) ! or arr = sgets ( 'fx_size_fx_len' ) if ( size ( arr ) /= 3 ) write ( * , * ) 'not right size' if ( len ( arr ) > 19 ) write ( * , * ) 'longer than wanted' call get_args ( 'fx_len_scalar' , a ) !or a = sget ( 'fx_len_scalar' ) if ( len ( a ) > 19 ) write ( * , * ) 'too long' write ( * , * ) a , len ( a ) write ( * , * ) arr , len ( arr ), size ( arr ) endblock end program demo5","tags":"","loc":"program/demo5.html"},{"title":"demo7 – M_CLI2","text":"Uses M_CLI2 @(#) controlling array delimiter characters Contents Variables characters complexs doubles dp fixed flen integers normal reals Source Code demo7 Variables Type Attributes Name Initial character(len=:), allocatable :: characters (:) complex, allocatable :: complexs (:) real(kind=dp), allocatable :: doubles (:) integer, parameter :: dp = kind(0.0d0) character(len=4) :: fixed (2) character(len=20), allocatable :: flen (:) integer, allocatable :: integers (:) real(kind=dp), allocatable :: normal (:) real, allocatable :: reals (:) Source Code program demo7 !! @(#) controlling array delimiter characters use M_CLI2 , only : set_args , get_args , get_args_fixed_size , get_args_fixed_length implicit none integer , parameter :: dp = kind ( 0.0d0 ) character ( len = 20 ), allocatable :: flen (:) ! allocatable array with fixed length character ( len = 4 ) :: fixed ( 2 ) ! fixed-size array wih fixed length integer , allocatable :: integers (:) real , allocatable :: reals (:) real ( kind = dp ), allocatable :: doubles (:) real ( kind = dp ), allocatable :: normal (:) complex , allocatable :: complexs (:) character ( len = :), allocatable :: characters (:) ! allocatable array with allocatable length print * , 'demo7: controlling array delimiter characters' ! ARRAY DELIMITERS ! ! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f) ! call set_args ( '-flen A,B,C -fixed X,Y --integers z --reals 111/222/333 -normal , --doubles | --complexs 0!0 --characters @' ) call get_args ( 'integers' , integers , delimiters = 'abcdefghijklmnopqrstuvwxyz' ) call get_args ( 'reals' , reals , delimiters = '/' ) call get_args ( 'doubles' , doubles , delimiters = '|' ) call get_args ( 'complexs' , complexs , delimiters = '!' ) call get_args ( 'normal' , normal ) call get_args ( 'characters' , characters , delimiters = '@' ) call get_args_fixed_length ( 'flen' , flen ) call get_args_fixed_size ( 'fixed' , fixed ) ! fixed length and fixed size array write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( flen ), 'flen=' , flen write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( characters ), 'characters=' , characters write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( integers ), 'integers=' , integers write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( reals ), 'reals=' , reals write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( doubles ), 'doubles=' , doubles write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( complexs ), 'complexs=' , complexs write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( normal ), 'normal=' , normal write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( fixed ), 'fixed=' , fixed end program demo7","tags":"","loc":"program/demo7.html"},{"title":"demo11 – M_CLI2","text":"Uses iso_fortran_env @(#) examples of validating values with ALL(3f) and ANY(3f) Contents Variables dot i list name readme string Derived Types point Source Code demo11 Variables Type Attributes Name Initial type( point ) :: dot integer :: i character(len=:), allocatable :: list (:) character(len=:), allocatable :: name character(len=80) :: readme character(len=:), allocatable :: string Derived Types type :: point Components Type Visibility Attributes Name Initial character(len=20), public :: color = 'red' integer, public :: x = 0 integer, public :: y = 0 Source Code program demo11 !! @(#) examples of validating values with ALL(3f) and ANY(3f) use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT implicit none type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point type ( point ) :: dot ; namelist / nml_dot / dot character ( len = :), allocatable :: name character ( len = :), allocatable :: string character ( len = :), allocatable :: list (:) character ( len = 80 ) :: readme !(3) integer :: i print * , 'demo11: examples of validating values with ALL(3f) and ANY(3f)' ! M_CLI2 intentionally does not have complex validators except for SPECIFIED(3f) and ! a check whether the input conforms to the type with get_args(3f) ! or the convenience functions like inum(3f). ! ! Fortran already has powerful validation capabilities. Logical ! expressions ANY(3f) and ALL(3f) are standard Fortran features easily ! allow performing the common validations for command line arguments ! without having to learn any additional syntax or methods. do i = 1 , 100 if ( all ([ i >= 10 , i <= 30 ,( i / 2 ) * 2 == i ])) then write ( * , * ) i , ' is an even number from 10 to 30 inclusive' endif enddo name = 'red' list = [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ] if ( any ( name == list ) ) then write ( * , * ) name , ' matches a value in the list' else write ( * , * ) name , ' not in the list' endif if ( size ( list ). eq . 3 ) then write ( * , * ) ' list has expected number of values' else write ( * , * ) ' list does not have expected number of values' endif ! and even user-defined types can be processed by reading the input ! as a string and using a NAMELIST(3f) group to convert it. Note that ! if input values are strings that have to be quoted (ie. more than one ! word) or contain characters special to the shell that how you have to ! quote the command line can get complicated. string = '10,20,\"green\"' readme = '&nml_dot dot=' // string // '/' ! some compilers might require the input to be on three lines !readme=[ character(len=80) ::& !'&nml_dot', & !'dot='//string//' ,', & !'/'] read ( readme , nml = nml_dot ) write ( * , * ) dot % x , dot % y , dot % color ! or write ( * , nml_dot ) ! Hopefully it is obvious how the options can be read from values gotten ! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f) ! in the first case, so this example just uses simple declarations to highlight ! some useful Fortran expressions that can be useful for validating the input ! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups. ! another alternative would be to validate expressions from strings using M_calculator(3f) ! but I find it easier to validate the values using regular Fortran code than doing it ! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by ! M_CLI2(3f) doing validation in the input forms themselves would be more desirable. end program demo11","tags":"","loc":"program/demo11.html"},{"title":"demo1 – M_CLI2","text":"Uses M_CLI2 @(#) using the convenience functions\nDECLARE “ARGS”\nSET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES\nALL DONE CRACKING THE COMMAND LINE. GET THE VALUES\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables anytitle l lupper point title x y z Source Code demo1 Variables Type Attributes Name Initial character(len=:), allocatable :: anytitle logical :: l logical :: lupper real :: point (3) character(len=:), allocatable :: title real :: x real :: y real :: z Source Code program demo1 !! @(#) using the convenience functions use M_CLI2 , only : set_args , get_args_fixed_size , set_mode use M_CLI2 , only : dget , iget , lget , rget , sget , cget ! for scalars use M_CLI2 , only : dgets , igets , lgets , rgets , sgets , cgets ! for allocatable arrays implicit none !! DECLARE \"ARGS\" real :: x , y , z , point ( 3 ) character ( len = :), allocatable :: title , anytitle logical :: l , lupper print * , 'demo1: using the convenience functions' call set_mode ( 'response_file' ) !! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES call set_args ( '-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T \"my title\" --anytitle:a \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) l = lget ( 'l' ) lupper = lget ( 'L' ) title = sget ( 'title' ) anytitle = sget ( 'anytitle' ) ! With a fixed-size array to ensure the correct number of values are input use call get_args_fixed_size ( 'point' , point ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z , ' point=' , point write ( * , '(*(g0:,1x))' ) 'title=' , trim ( title ), ' l=' , l , 'L=' , lupper write ( * , '(*(g0:,1x))' ) 'anytitle=' , trim ( anytitle ) end program demo1","tags":"","loc":"program/demo1.html"},{"title":"demo4 – M_CLI2","text":"Uses M_CLI2 @(#) COMPLEX type values Contents Variables aarr form forms three x y z Source Code demo4 Variables Type Attributes Name Initial complex, allocatable :: aarr (:) character(len=*), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character(len=*), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' complex :: three (3) complex :: x complex :: y complex :: z Source Code program demo4 !! @(#) _COMPLEX_ type values use M_CLI2 , only : set_args , get_args , get_args_fixed_size implicit none complex :: x , y , z ! scalars complex , allocatable :: aarr (:) ! allocatable array complex :: three ( 3 ) ! fixed-size array ! formats to pretty-print a complex value and small complex vector character ( len =* ), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character ( len =* ), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' print * , 'demo4: COMPLEX argument example' ! COMPLEX VALUES ! ! o parenthesis are optional and are ignored in complex values. ! ! o base#value is acceptable for base 2 to 32 for whole numbers, ! which is why \"i\" is not allowed as a suffix on imaginary values ! (because some bases include \"i\" as a digit). ! ! o normally arrays are allocatable. if a fixed size array is used ! call get_args_fixed_size(3f) and all the values must be ! specified. This is useful when you have something that requires ! a specific number of values. Perhaps a point in space must always ! have three values, for example. ! ! o default delimiters are whitespace, comma and colon. Note that ! whitespace delimiters should not be used in the definition, ! but are OK on command input if the entire parameter value is ! quoted. Using space delimiters in the prototype definition is ! not supported (but works) and requires that the value be quoted ! on input in common shells. Adjacent delimiters are treated as ! a single delimiter. ! call set_args ( '-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444' ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'three' , three ) call get_args ( 'aarr' , aarr ) write ( * , form ) x , y , z , x + y + z write ( * , forms ) three write ( * , forms ) aarr end program demo4","tags":"","loc":"program/demo4.html"},{"title":"demo16 – M_CLI2","text":"Uses M_CLI2 iso_fortran_env @(#) unnamed to numbers\nThe default for inums, rnums, … is to convert all unnamed argument values in “unnamed” Contents Variables all Subroutines runit Source Code demo16 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(1x,*(g0,1x))' Subroutines subroutine runit (string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string Source Code program demo16 !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets implicit none character ( len =* ), parameter :: all = '(1x,*(g0,1x))' call set_args ( '-type test' ) select case ( sget ( 'type' )) case ( 'i' , 'int' , 'integer' ); print all , igets () case ( 'r' , 'real' ); print all , rgets () case ( 'd' , 'double' ); print all , dgets () case ( 'test' ) print * , 'demo16: convert all arguments to numerics' ! positive BOZ whole number values are allowed ! e-format is allowed, ints(3f) truncates call runit ( '-type i 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) call runit ( '-type r 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) call runit ( '-type d 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) case default print all , 'unknown type' end select contains subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program demo16","tags":"","loc":"program/demo16.html"},{"title":"demo8 – M_CLI2","text":"Uses M_CLI2 @(#) Sometimes you can put multiple values on getargs(3f) Contents Variables l pairs size title x y Source Code demo8 Variables Type Attributes Name Initial logical :: l character(len=*), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' real :: size character(len=80) :: title integer :: x integer :: y Source Code program demo8 !! @(#) Sometimes you can put multiple values on getargs(3f) use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = 80 ) :: title character ( len =* ), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' print * , 'demo8: Sometimes you can put multiple values on getargs(3f)' ! DEFINE COMMAND AND PARSE COMMAND LINE ! set all values, double-quote strings call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! GET THE VALUES ! only fixed scalar values (including only character variables that ! are fixed length) may be combined in one GET_ARGS(3f) call call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size , 'title' , title ) ! USE THE VALUES write ( * , fmt = pairs ) 'X' , x , 'Y' , y , 'size' , size , 'L' , l , 'TITLE' , title end program demo8","tags":"","loc":"program/demo8.html"},{"title":"demo18 – M_CLI2","text":"Uses M_CLI2 @(#) using the convenience functions\nUSE THE VALUES IN YOUR PROGRAM. Contents Variables a b o o_up ox t x x_up xo Source Code demo18 Variables Type Attributes Name Initial logical :: a logical :: b logical :: o logical :: o_up logical :: ox logical :: t logical :: x logical :: x_up logical :: xo Source Code program demo18 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , get_args implicit none logical :: o , x , t , ox , xo , x_up , o_up , a , b print * , 'demo18: using the bundling option' call set_mode ( 'strict' ) call set_mode ( 'ignorecase' ) call set_args ( '-x F -o F -X F -O F -t F --ox F -xo F -longa:a F -longb:b' ) call get_args ( 'x' , x , 'o' , o , 't' , t , 'xo' , xo , 'ox' , ox , 'X' , x_up , 'O' , o_up ) call get_args ( 'longa' , a , 'longb' , b ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'o=' , o , 't=' , t write ( * , '(*(g0:,1x))' ) 'ox=' , ox , 'xo=' , xo write ( * , '(*(g0:,1x))' ) 'O=' , o_up , 'X=' , x_up write ( * , '(*(g0:,1x))' ) 'longa=' , a , 'longb=' , b end program demo18","tags":"","loc":"program/demo18.html"},{"title":"demo13 – M_CLI2","text":"Uses M_CLI2 @(#) underdash mode\nAny dash in a key name is treated as an underscore\nwhen underdash mode is on demo13 --switch-X\ndemo13 --switch_X are equivalent when this mode is on Contents Variables all Source Code demo13 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo13 !> @(#) underdash mode !! Any dash in a key name is treated as an underscore !! when underdash mode is on !! !! demo13 --switch-X !! demo13 --switch_X !! !! are equivalent when this mode is on !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo13: underdash mode' call set_mode ( 'underdash' ) call set_args ( ' --switch_X:X F --switch-Y:Y F ' ) print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) end program demo13","tags":"","loc":"program/demo13.html"},{"title":"demo14 – M_CLI2","text":"Uses M_CLI2 @(#) ignorecase mode long keynames are internally converted to lowercase\nwhen ignorecase mode is on these are equivalent demo14 --longName\ndemo14 --longname\ndemo14 --LongName Values and short names remain case-sensitive Contents Variables all Source Code demo14 Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo14 !> @(#) ignorecase mode !! !! long keynames are internally converted to lowercase !! when ignorecase mode is on these are equivalent !! !! demo14 --longName !! demo14 --longname !! demo14 --LongName !! !! Values and short names remain case-sensitive !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo14: ignorecase mode' call set_mode ( 'ignorecase' ) call set_args ( ' --longName:N F ' ) print all , '--longName or -N ... ' , lget ( 'longName' ) end program demo14","tags":"","loc":"program/demo14.html"},{"title":"demo_get_args_fixed_length – M_CLI2","text":"Uses M_CLI2 Contents Variables title Source Code demo_get_args_fixed_length Variables Type Attributes Name Initial character(len=80) :: title Source Code program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! Define args character ( len = 80 ) :: title ! Parse command line call set_args ( ' --title \"my title\" ' ) ! Assign values to variables call get_args_fixed_length ( 'title' , title ) ! Use values write ( * , * ) 'title=' , title end program demo_get_args_fixed_length","tags":"","loc":"program/demo_get_args_fixed_length.html"},{"title":"demo_get_subcommand – M_CLI2","text":"Contents Variables l l_ name testname title x y z Subroutines parse Source Code demo_get_subcommand Variables Type Attributes Name Initial logical :: l = .false. logical :: l_ = .false. character(len=20) :: name character(len=80) :: testname = \"not set\" character(len=80) :: title = \"not set\" real :: x = -999.0 real :: y = -999.0 real :: z = -999.0 Subroutines subroutine parse (name) Arguments Type Intent Optional Attributes Name character(len=*) :: name Source Code program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z --title -l -L !x! demo_get_subcommand test --title -l -L --testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x =- 99 9.0 , y =- 99 9.0 , z =- 99 9.0 character ( len = 80 ) :: title = \"not set\" logical :: l = . false . logical :: l_ = . false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) !x! DEFINE AND PARSE COMMAND LINE !x! ALL DONE CRACKING THE COMMAND LINE. !x! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'command was ' , name write ( * , * ) 'x,y,z .... ' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , testname contains subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L --title -x -y -z ' , & ' * test -l -L --title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand","tags":"","loc":"program/demo_get_subcommand.html"},{"title":"demo_set_mode – M_CLI2","text":"Uses M_CLI2 Contents Variables all Source Code demo_set_mode Variables Type Attributes Name Initial character(len=*), parameter :: all = '(*(g0))' Source Code program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' ! ! enable use of response files call set_mode ( 'response_file' ) ! ! Any dash in a keyword is treated as an underscore call set_mode ( 'underdash' ) ! ! The case of long keywords are ignored. ! Values and short names remain case-sensitive call set_mode ( 'ignorecase' ) ! ! short single-character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keywords. call set_mode ( 'strict' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F' ) ! print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) print all , '--ox or -O ... ' , lget ( 'ox' ) print all , '-o ... ' , lget ( 'o' ) print all , '-x ... ' , lget ( 'x' ) print all , '-t ... ' , lget ( 't' ) end program demo_set_mode","tags":"","loc":"program/demo_set_mode.html"},{"title":"demo_get_args_fixed_size – M_CLI2","text":"Uses M_CLI2 Contents Variables cmp dp l lbig p title x y Source Code demo_get_args_fixed_size Variables Type Attributes Name Initial complex :: cmp (2) integer, parameter :: dp = kind(0.0d0) logical :: l (4) logical :: lbig (4) integer :: p (3) character(len=80) :: title (1) real :: x (2) real(kind=dp) :: y (2) Source Code program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0.0d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ), lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings ! o set all logical values to F or T. call set_args ( ' & & -x 10.0,20.0 & & -y 11.0,22.0 & & -p -1,-2,-3 & & --title \"my title\" & & -l F,T,F,T -L T,F,T,F & & --cmp 111,222.0,333.0e0,4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( 'x' , x ) call get_args_fixed_size ( 'y' , y ) call get_args_fixed_size ( 'p' , p ) call get_args_fixed_size ( 'title' , title ) call get_args_fixed_size ( 'l' , l ) call get_args_fixed_size ( 'L' , lbig ) call get_args_fixed_size ( 'cmp' , cmp ) ! USE VALUES write ( * , * ) 'x=' , x write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig write ( * , * ) 'cmp=' , cmp end program demo_get_args_fixed_size","tags":"","loc":"program/demo_get_args_fixed_size.html"},{"title":"demo_specified – M_CLI2","text":"Uses M_CLI2 iso_fortran_env Contents Variables color flag floats i ints list Source Code demo_specified Variables Type Attributes Name Initial character(len=:), allocatable :: color logical :: flag real, allocatable :: floats (:) integer :: i integer, allocatable :: ints (:) character(len=:), allocatable :: list (:) Source Code program demo_specified use , intrinsic :: iso_fortran_env , only : & & stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , igets , rgets , specified , sget , lget implicit none ! Define args integer , allocatable :: ints (:) real , allocatable :: floats (:) logical :: flag character ( len = :), allocatable :: color character ( len = :), allocatable :: list (:) integer :: i call set_args ( '& & --color:c \"red\" & & --flag:f F & & --ints:i 1,10,11 & & --floats:T 12.3, 4.56 & & ' ) ints = igets ( 'ints' ) floats = rgets ( 'floats' ) flag = lget ( 'flag' ) color = sget ( 'color' ) write ( * , * ) 'color=' , color write ( * , * ) 'flag=' , flag write ( * , * ) 'ints=' , ints write ( * , * ) 'floats=' , floats write ( * , * ) 'was -flag specified?' , specified ( 'flag' ) ! elemental write ( * , * ) specified ([ 'floats' , 'ints ' ]) ! If you want to know if groups of parameters were specified use ! ANY(3f) and ALL(3f) write ( * , * ) 'ANY:' , any ( specified ([ 'floats' , 'ints ' ])) write ( * , * ) 'ALL:' , all ( specified ([ 'floats' , 'ints ' ])) ! For mutually exclusive if ( all ( specified ([ 'floats' , 'ints ' ]))) then write ( * , * ) 'You specified both names --ints and --floats' endif ! For required parameter if (. not . any ( specified ([ 'floats' , 'ints ' ]))) then write ( * , * ) 'You must specify --ints or --floats' endif ! check if all values are in range from 10 to 30 and even write ( * , * ) 'are all numbers good?' , all ([ ints >= 10 , ints <= 30 ,( ints / 2 ) * 2 == ints ]) ! perhaps you want to check one value at a time do i = 1 , size ( ints ) write ( * , * ) ints ( i ),[ ints ( i ) >= 10 , ints ( i ) <= 30 ,( ints ( i ) / 2 ) * 2 == ints ( i )] if ( all ([ ints ( i ) >= 10 , ints ( i ) <= 30 ,( ints ( i ) / 2 ) * 2 == ints ( i )]) ) then write ( * , * ) ints ( i ), 'is an even number from 10 to 30 inclusive' else write ( * , * ) ints ( i ), 'is not an even number from 10 to 30 inclusive' endif enddo list = [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ] if ( any ( color == list ) ) then write ( * , * ) color , 'matches a value in the list' else write ( * , * ) color , 'not in the list' endif if ( size ( ints ). eq . 3 ) then write ( * , * ) 'ints(:) has expected number of values' else write ( * , * ) 'ints(:) does not have expected number of values' endif end program demo_specified","tags":"","loc":"program/demo_specified.html"},{"title":"demo_get_args – M_CLI2","text":"Uses M_CLI2 Contents Variables i l lbig p title x y z Source Code demo_get_args Variables Type Attributes Name Initial integer :: i logical :: l logical :: lbig real, allocatable :: p (:) character(len=:), allocatable :: title real :: x real :: y real :: z Source Code program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! Define ARGS real :: x , y , z real , allocatable :: p (:) character ( len = :), allocatable :: title logical :: l , lbig ! Define and parse (to set initial values) command line ! o only quote strings and use double-quotes ! o set all logical values to F or T. call set_args ( ' & & -x 1 -y 2 -z 3 & & -p -1,-2,-3 & & --title \"my title\" & & -l F -L F & & --label \" \" & & ' ) ! Assign values to elements ! Scalars call get_args ( 'x' , x , 'y' , y , 'z' , z , 'l' , l , 'L' , lbig ) ! Allocatable string call get_args ( 'title' , title ) ! Allocatable arrays call get_args ( 'p' , p ) ! Use values write ( * , '(1x,g0,\"=\",g0)' ) 'x' , x , 'y' , y , 'z' , z write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig if ( size ( filenames ) > 0 ) then write ( * , '(i6.6,3a)' )( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) endif end program demo_get_args","tags":"","loc":"program/demo_get_args.html"},{"title":"test_syntax – M_CLI2","text":"Uses M_CLI2 iso_fortran_env @(#) unnamed to numbers\nThe default for inums, rnums, … is to convert all unnamed argument values in “unnamed” Contents Variables it whichone Subroutines runit testit Source Code test_syntax Variables Type Attributes Name Initial character(len=*), parameter :: it = '(1x,*(g0,1x))' character(len=:), allocatable :: whichone Subroutines subroutine runit (string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string subroutine testit (string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Source Code program test_syntax !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , sgets , iget , igets , rget , rgets , dget , dgets , lget , lgets implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' character ( len = :), allocatable :: whichone call set_args ( ' --type run -i 1 --ints:I 1,2,3 -s \" \" --strings \" \" -r 0.0 --reals:R 11.1,22.2,33.3' ) whichone = sget ( 'type' ) select case ( whichone ) case ( 'one' ) call testit ( whichone // ' i' , iget ( 'i' ) == 1 ) call testit ( whichone // ' ints' , all ( igets ( 'ints' ) == [ 1 , 2 , 3 ])) call testit ( whichone // ' r' , rget ( 'r' ) == 0.0 ) call testit ( whichone // ' reals' , all ( rgets ( 'reals' ) == [ 1 1.1 , 2 2.2 , 3 3.3 ])) call testit ( whichone // ' s' , sget ( 's' ) == \" \" ) call testit ( whichone // ' strings' , all ( sgets ( 'strings' ) == [ \" \" ])) case ( 'two' ) call testit ( whichone // ' ints' , all ( igets ( 'ints' ) == [ 0 , 1 , 2 , 20 , 30 , 40 , 300 , 400 , 1000 , 2000 ])) case ( 'three' ) write ( * , it ) 'three:size=' , size ( sgets ( 'strings' )) write ( * , '(*(\"[\",a,\"]\":,1x))' ) sgets ( 'strings' ) case ( 'run' ) print * , 'test_syntax: syntax mode' call runit ( '--type one -u' ) call runit ( '--type one ' ) call runit ( '--type two -I 0,1,2 --ints=20:30:40 --ints 300,400 -I=1000,2000' ) call runit ( '--type three' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test if ( test ) then print it , ':syntax:' , string , 'passed' else print it , ':syntax:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_syntax","tags":"","loc":"program/test_syntax.html"},{"title":"test_lastonly – M_CLI2","text":"Uses M_CLI2 iso_fortran_env @(#) unnamed to numbers\nThe default for inums, rnums, … is to convert all unnamed argument values in “unnamed” Contents Variables F T arr it whichone Subroutines runit testit Source Code test_lastonly Variables Type Attributes Name Initial logical, parameter :: F = .false. logical, parameter :: T = .true. logical, allocatable :: arr (:) character(len=*), parameter :: it = '(1x,*(g0,1x))' character(len=:), allocatable :: whichone Subroutines subroutine runit (string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string subroutine testit (string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Source Code program test_lastonly !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' logical , parameter :: T = . true ., F = . false . character ( len = :), allocatable :: whichone logical , allocatable :: arr (:) call set_mode ( 'strict' ) call set_mode ( 'lastonly' ) call set_args ( ' --type run -o F -t F -x F --ox F --xo F --longa:O F --longb:X F -a \"aaa\" --stringb:b \"bbb BBB\" -c \"cc c C CC\"' ) whichone = sget ( 'type' ) arr = [ lget ( 'o' ), lget ( 't' ), lget ( 'x' ), lget ( 'ox' ), lget ( 'xo' ), lget ( 'longa' ), lget ( 'longb' )] select case ( whichone ) case ( 'one' ) ; call testit ( whichone ,. not . any ( arr )) case ( 'two' ) ; call testit ( whichone , all ( arr )) case ( 'three' ) ; call testit ( whichone , all ( arr )) case ( 'four' ) ; call testit ( whichone , all ( arr . eqv .[ F , F , F , F , F , T , F ])) case ( 'five' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , T , T ])) case ( 'six' ) ; call testit ( whichone , all ( arr )) case ( 'seven' ) ; print it , 'a=' , sget ( 'a' ); call testit ( whichone , sget ( 'a' ) == 'a b c' ) case ( 'eight' ) ; print it , 'stringb=' , sget ( 'stringb' ); call testit ( whichone , sget ( 'stringb' ) == 'a b c' ) case ( 'nine' ) ; print it , 'stringb=' , sget ( 'stringb' ); call testit ( whichone , sget ( 'stringb' ) == 'a b c' ) case ( 'run' ) print * , 'test_lastonly: lastonly mode' call runit ( '--type one' ) call runit ( '--type two -oxt --ox --xo -OX --longa --longb' ) call runit ( '--type three -t -o -x --ox --xo -O -X --longa --longb' ) call runit ( '--type four --longa --longa --longa --longa' ) call runit ( '--type five -t -o -x --longa --longb -O -X -OX -XO --longb' ) call runit ( '--type six -ox -t --ox --xo --longa --longb -xt -o --ox --xo --longa --longb' ) call runit ( '--type seven -a \"a b c\"' ) call runit ( '--type eight -b \"a b c\"' ) call runit ( '--type nine --stringb \"a b c\"' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':lastonly:' , string , 'passed' else print it , ':lastonly:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_lastonly","tags":"","loc":"program/test_lastonly.html"},{"title":"test_ignorecase – M_CLI2","text":"Uses M_CLI2 iso_fortran_env @(#) unnamed to numbers\nThe default for inums, rnums, … is to convert all unnamed argument values in “unnamed” Contents Variables arr it whichone Subroutines runit testit Source Code test_ignorecase Variables Type Attributes Name Initial character(len=:), allocatable :: arr (:) character(len=*), parameter :: it = '(1x,*(g0,1x))' character(len=:), allocatable :: whichone Subroutines subroutine runit (string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string subroutine testit (string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Source Code program test_ignorecase !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' character ( len = :), allocatable :: whichone character ( len = :), allocatable :: arr (:) call set_mode ( 'ignorecase' ) call set_args ( ' --type run -a \"a AA a\" -b \"B bb B\" -A AAA -B BBB --longa:O \" OoO \" --longb:X \"xXx\"' ) whichone = sget ( 'type' ) arr = [ character ( len = 17 ) :: sget ( 'a' ), sget ( 'b' ), sget ( 'A' ), sget ( 'B' ), sget ( 'longa' ), sget ( 'longb' ), sget ( 'O' ), sget ( 'X' ) ] select case ( whichone ) case ( 'one' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a AA a' , 'B bb B' , 'AAA' , 'BBB' , ' OoO' , 'xXx' , ' OoO' , 'xXx' ] == arr )) case ( 'two' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a' , 'b' , 'A' , 'B' , 'longa O' , 'longb X' , 'longa O' , 'longb X' ] == arr )) case ( 'three' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a' , 'b' , 'A' , 'B' , 'longa O' , 'longb X' , 'longa O' , 'longb X' ] == arr )) case ( 'four' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a A' , 'b B' , 'SET A' , 'SET B' , ' OoO' , 'xXx' , ' OoO' , 'xXx' ] == arr )) case ( 'five' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a AA a' , 'B bb B' , 'AAA' , 'BBB' , & & 'a b c d e f g h i' , 'xXx' , 'a b c d e f g h i' , 'xXx' ] == arr )) case ( 'six' ) ; !call testit(whichone, all(arr)) case ( 'run' ) print * , 'test_ignorecase: ignorecase mode' call runit ( '--type one ' ) call runit ( '--type two -a a -b b -A A -B B -longa longa -longb longb -O O -X X ' ) call runit ( '--type three -a a -b b -A A -B B -LONGA longa -LONGB longb -O O -X X' ) call runit ( '--type four -a a -b b -a A -b B -A \"SET A\" -B \"SET B\"' ) call runit ( '--type five --LongA \"a b c\" -longa \"d e f\" -longA \"g h i\"' ) ! call runit('--type six -ox -t --ox --xo --longa --longb') case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':ignorecase:' , string , 'passed' else print it , ':ignorecase:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_ignorecase","tags":"","loc":"program/test_ignorecase.html"},{"title":"test_strict – M_CLI2","text":"Uses M_CLI2 iso_fortran_env @(#) unnamed to numbers\nThe default for inums, rnums, … is to convert all unnamed argument values in “unnamed” Contents Variables F T arr it whichone Subroutines runit testit Source Code test_strict Variables Type Attributes Name Initial logical, parameter :: F = .false. logical, parameter :: T = .true. logical, allocatable :: arr (:) character(len=*), parameter :: it = '(1x,*(g0,1x))' character(len=:), allocatable :: whichone Subroutines subroutine runit (string) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string subroutine testit (string, test) Arguments Type Intent Optional Attributes Name character(len=*), intent(in) :: string logical, intent(in) :: test Source Code program test_strict !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' logical , parameter :: T = . true ., F = . false . character ( len = :), allocatable :: whichone logical , allocatable :: arr (:) call set_mode ( 'strict' ) call set_args ( ' --type run -o F -t F -x F --ox F --xo F --longa:O F --longb:X F' ) whichone = sget ( 'type' ) arr = [ lget ( 'o' ), lget ( 't' ), lget ( 'x' ), lget ( 'ox' ), lget ( 'xo' ), lget ( 'longa' ), lget ( 'longb' )] select case ( whichone ) case ( 'one' ) ; call testit ( whichone ,. not . any ( arr )) case ( 'two' ) ; call testit ( whichone , all ( arr )) case ( 'three' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , F , F ])) case ( 'four' ) ; call testit ( whichone , all ( arr . eqv .[ F , F , F , T , T , F , F ])) case ( 'five' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , F , F ])) case ( 'six' ) ; call testit ( whichone , all ( arr )) case ( 'run' ) print * , 'test_strict: strict mode' call runit ( '--type one ' ) call runit ( '--type two -ox -t --ox --xo -OX' ) call runit ( '--type three -tox ' ) call runit ( '--type four --ox --xo' ) call runit ( '--type five -t -o -x ' ) call runit ( '--type six -ox -t --ox --xo --longa --longb' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':strict:' , string , 'passed' else print it , ':strict:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_strict","tags":"","loc":"program/test_strict.html"},{"title":"M_CLI2.F90 – M_CLI2","text":"Contents Modules M_CLI2 Source Code M_CLI2.F90 Source Code !VERSION 1.0 20200115 !VERSION 2.0 20200802 !VERSION 3.0 20201021 LONG:SHORT syntax !VERSION 3.1 20201115 LONG:SHORT:: syntax !VERSION 3.2 20230205 set_mode() !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! M_CLI2(3fm) - [ARGUMENTS::M_CLI2::INTRO] command line argument !! parsing using a prototype command !! (LICENSE:PD) !!##SYNOPSIS !! !! Available procedures and variables: !! !! ! basic procedures !! use M_CLI2, only : set_args, get_args, specified, set_mode !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! ! variables !! use M_CLI2, only : unnamed, remaining, args !! ! working with non-allocatable strings and arrays !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! ! special function for creating subcommands !! use M_CLI2, only : get_subcommand(3f) !! !!##DESCRIPTION !! The M_CLI2 module cracks a Unix-style command line. !! !! Typically one call to SET_ARGS(3f) is made to define the command !! arguments, set default values and parse the command line. Then a call !! is made to the convenience procedures or GET_ARGS(3f) proper for each !! command keyword to obtain the argument values. !! !! Detailed descriptions of each procedure and example programs are !! included. !! !!##EXAMPLE !! !! !! Sample minimal program which may be called in various ways: !! !! mimimal -x 100.3 -y 3.0e4 !! mimimal --xvalue=300 --debug !! mimimal --yvalue 400 !! mimimal -x 10 file1 file2 file3 !! !! Program example: !! !! program minimal !! use M_CLI2, only : set_args, lget, rget, sgets !! implicit none !! real :: x, y !! integer :: i !! character(len=:),allocatable :: filenames(:) !! ! define and crack command line !! call set_args(' --yvalue:y 0.0 --xvalue:x 0.0 --debug F') !! ! get values !! x=rget('xvalue') !! y=rget('yvalue') !! if(lget('debug'))then !! write(*,*)'X=',x !! write(*,*)'Y=',y !! write(*,*)'ATAN2(Y,X)=',atan2(x=x,y=y) !! else !! write(*,*)atan2(x=x,y=y) !! endif !! filenames=sgets() ! sget with no name gets \"unnamed\" values !! if(size(filenames) > 0)then !! write(*,'(g0)')'filenames:' !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program minimal !! !! Sample program using get_args() and variants !! !! program demo_M_CLI2 !! use M_CLI2, only : set_args, get_args !! use M_CLI2, only : filenames=>unnamed !! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size !! implicit none !! integer :: i !! integer,parameter :: dp=kind(0.0d0) !! ! !! ! Define ARGS !! real :: x, y, z !! logical :: l, lbig !! character(len=40) :: label ! FIXED LENGTH !! real(kind=dp),allocatable :: point(:) !! logical,allocatable :: logicals(:) !! character(len=:),allocatable :: title ! VARIABLE LENGTH !! real :: p(3) ! FIXED SIZE !! logical :: logi(3) ! FIXED SIZE !! ! !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o set a value for all keywords. !! ! o double-quote strings, strings must be at least one space !! ! because adjacent double-quotes designate a double-quote !! ! in the value. !! ! o set all logical values to F !! ! o numeric values support an \"e\" or \"E\" exponent !! ! o for lists delimit with a comma, colon, or space !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1 -2 -3 & !! & --point 11.11, 22.22, 33.33e0 & !! & --title \"my title\" -l F -L F & !! & --logicals F F F F F & !! & --logi F T F & !! & --label \" \" & !! ! note space between quotes is required !! & ') !! ! Assign values to elements using G_ARGS(3f). !! ! non-allocatable scalars can be done up to twenty per call !! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig) !! ! As a convenience multiple pairs of keywords and variables may be !! ! specified if and only if all the values are scalars and the CHARACTER !! ! variables are fixed-length or pre-allocated. !! ! !! ! After SET_ARGS(3f) has parsed the command line !! ! GET_ARGS(3f) retrieves the value of keywords accept for !! ! two special cases. For fixed-length CHARACTER variables !! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! ! GET_ARGS_FIXED_SIZE(3f). !! ! !! ! allocatables should be done one at a time !! call get_args('title',title) ! allocatable string !! call get_args('point',point) ! allocatable arrays !! call get_args('logicals',logicals) !! ! !! ! less commonly ... !! !! ! for fixed-length strings !! call get_args_fixed_length('label',label) !! !! ! for non-allocatable arrays !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('logi',logi) !! ! !! ! all done parsing, use values !! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z !! write(*,*)'p=',p !! write(*,*)'point=',point !! write(*,*)'title=',title !! write(*,*)'label=',label !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'logicals=',logicals !! write(*,*)'logi=',logi !! ! !! ! unnamed strings !! ! !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! ! !! end program demo_M_CLI2 !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !!##SEE ALSO !! + get_args(3f) !! + get_args_fixed_size(3f) !! + get_args_fixed_length(3f) !! + get_subcommand(3f) !! + set_mode(3f) !! + specified(3f) !! !! Note that the convenience routines are described under get_args(3f): !! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f), !! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f) !=================================================================================================================================== module M_CLI2 use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT , warn => OUTPUT_UNIT implicit none private integer , parameter , private :: dp = kind ( 0.0d0 ) integer , parameter , private :: sp = kind ( 0.0 ) character ( len =* ), parameter :: gen = '(*(g0))' character ( len = :), allocatable , public :: unnamed (:) character ( len = :), allocatable , public :: args (:) character ( len = :), allocatable , public :: remaining public :: set_mode public :: set_args public :: get_subcommand public :: get_args public :: get_args_fixed_size public :: get_args_fixed_length public :: specified public :: print_dictionary public :: dget , iget , lget , rget , sget , cget public :: dgets , igets , lgets , rgets , sgets , cgets type option character (:), allocatable :: shortname character (:), allocatable :: longname character (:), allocatable :: value integer :: length logical :: present_in logical :: mandatory end type option character ( len = :), allocatable , save :: keywords (:) character ( len = :), allocatable , save :: shorts (:) character ( len = :), allocatable , save :: values (:) integer , allocatable , save :: counts (:) logical , allocatable , save :: present_in (:) logical , allocatable , save :: mandatory (:) logical , save :: G_DEBUG = . false . logical , save :: G_UNDERDASH = . false . logical , save :: G_NOSEPARATOR = . false . logical , save :: G_IGNORECASE = . false . ! ignore case of long keywords logical , save :: G_STRICT = . false . ! strict short and long rules or allow -longname and --shortname logical , save :: G_APPEND = . true . ! whether to append or replace when duplicate keywords found logical , save :: G_keyword_single_letter = . true . character ( len = :), allocatable , save :: G_passed_in logical , save :: G_remaining_on , G_remaining_option_allowed character ( len = :), allocatable , save :: G_remaining character ( len = :), allocatable , save :: G_subcommand ! possible candidate for a subcommand character ( len = :), allocatable , save :: G_STOP_MESSAGE integer , save :: G_STOP logical , save :: G_QUIET character ( len = :), allocatable , save :: G_PREFIX ! try out response files ! CLI_RESPONSE_FILE is left public for backward compatibility, but should be set via \"set_mode('response_file') logical , save , public :: CLI_RESPONSE_FILE = . false . ! allow @name abbreviations logical , save :: G_OPTIONS_ONLY ! process response file only looking for options for get_subcommand() logical , save :: G_RESPONSE ! allow @name abbreviations character ( len = :), allocatable , save :: G_RESPONSE_IGNORED ! return allocatable arrays interface get_args ; module procedure get_anyarray_d ; end interface ! any size array interface get_args ; module procedure get_anyarray_i ; end interface ! any size array interface get_args ; module procedure get_anyarray_r ; end interface ! any size array interface get_args ; module procedure get_anyarray_x ; end interface ! any size array interface get_args ; module procedure get_anyarray_c ; end interface ! any size array and any length interface get_args ; module procedure get_anyarray_l ; end interface ! any size array ! return scalars interface get_args ; module procedure get_scalar_d ; end interface interface get_args ; module procedure get_scalar_i ; end interface interface get_args ; module procedure get_scalar_real ; end interface interface get_args ; module procedure get_scalar_complex ; end interface interface get_args ; module procedure get_scalar_logical ; end interface interface get_args ; module procedure get_scalar_anylength_c ; end interface ! any length ! multiple scalars interface get_args ; module procedure many_args ; end interface ! return non-allocatable arrays ! said in conflict with get_args_*. Using class to get around that. ! that did not work either. Adding size parameter as optional parameter works; but using a different name interface get_args_fixed_size ; module procedure get_fixedarray_class ; end interface ! any length, fixed size array !interface get_args; module procedure get_fixedarray_d; end interface !interface get_args; module procedure get_fixedarray_i; end interface !interface get_args; module procedure get_fixedarray_r; end interface !interface get_args; module procedure get_fixedarray_l; end interface !interface get_args; module procedure get_fixedarray_fixed_length_c; end interface interface get_args_fixed_length ; module procedure get_args_fixed_length_a_array ; end interface ! fixed length any size array interface get_args_fixed_length ; module procedure get_args_fixed_length_scalar_c ; end interface ! fixed length ! Generic subroutine inserts element into allocatable array at specified position ! find PLACE in sorted character array where value can be found or should be placed interface locate_ ; module procedure locate_c ; end interface ! insert entry into a sorted allocatable array at specified position interface insert_ ; module procedure insert_c , insert_i , insert_l ; end interface ! replace entry by index from a sorted allocatable array if it is present interface replace_ ; module procedure replace_c , replace_i , replace_l ; end interface ! delete entry by index from a sorted allocatable array if it is present interface remove_ ; module procedure remove_c , remove_i , remove_l ; end interface ! convenience functions interface cgets ; module procedure cgs , cg ; end interface interface dgets ; module procedure dgs , dg ; end interface interface igets ; module procedure igs , ig ; end interface interface lgets ; module procedure lgs , lg ; end interface interface rgets ; module procedure rgs , rg ; end interface interface sgets ; module procedure sgs , sg ; end interface contains !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process !! pre-defined options !! !!##SYNOPSIS !! !! subroutine check_commandline(help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! !!##DESCRIPTION !! Checks the commandline and processes the implicit --help, --version, !! --verbose, and --usage parameters. !! !! If the optional text values are supplied they will be displayed by !! --help and --version command-line options, respectively. !! !!##OPTIONS !! !! HELP_TEXT if present, will be displayed if program is called with !! --help switch, and then the program will terminate. If !! not supplied, the command line initialized string will be !! shown when --help is used on the commandline. !! !! VERSION_TEXT if present, will be displayed if program is called with !! --version switch, and then the program will terminate. !! !! If the first four characters of each line are \"@(#)\" this prefix !! will not be displayed and the last non-blank letter will be !! removed from each line. This if for support of the SCCS what(1) !! command. If you do not have the what(1) command on GNU/Linux and !! Unix platforms you can probably see how it can be used to place !! metadata in a binary by entering: !! !! strings demo_commandline|grep '@(#)'|tr '>' '\\n'|sed -e 's/ */ /g' !! !!##EXAMPLE !! !! !! Typical usage: !! !! program check_commandline !! use M_CLI2, only : unnamed, set_args, get_args !! implicit none !! integer :: i !! character(len=:),allocatable :: version_text(:), help_text(:) !! real :: x, y, z !! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' !! version_text=[character(len=80) :: \"version 1.0\",\"author: me\"] !! help_text=[character(len=80) :: & !! & \"wish I put instructions\",\"here\",\"I suppose?\"] !! call set_args(cmd,help_text,version_text) !! call get_args('x',x,'y',y,'z',z) !! ! All done cracking the command line. Use the values in your program. !! write (*,*)x,y,z !! ! the optional unnamed values on the command line are !! ! accumulated in the character array \"UNNAMED\" !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program check_commandline !=================================================================================================================================== subroutine check_commandline ( help_text , version_text ) character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len = :), allocatable :: line integer :: i integer :: istart integer :: iback if ( get ( 'usage' ) == 'T' ) then call print_dictionary ( 'USAGE:' ) call mystop ( 32 ) return endif if ( present ( help_text )) then if ( get ( 'help' ) == 'T' ) then do i = 1 , size ( help_text ) call journal ( help_text ( i )) enddo call mystop ( 1 , 'displayed help text' ) return endif elseif ( get ( 'help' ) == 'T' ) then call default_help () call mystop ( 2 , 'displayed default help text' ) return endif if ( present ( version_text )) then if ( get ( 'version' ) == 'T' ) then istart = 1 iback = 0 if ( size ( version_text ) > 0 ) then if ( index ( version_text ( 1 ), '@' // '(#)' ) == 1 ) then ! allow for what(1) syntax istart = 5 iback = 1 endif endif do i = 1 , size ( version_text ) !xINTEL BUG*!call journal(version_text(i)(istart:len_trim(version_text(i))-iback)) line = version_text ( i )( istart : len_trim ( version_text ( i )) - iback ) call journal ( line ) enddo call mystop ( 3 , 'displayed version text' ) return endif elseif ( get ( 'version' ) == 'T' ) then if ( G_QUIET ) then G_STOP_MESSAGE = 'no version text' else call journal ( '*check_commandline* no version text' ) endif call mystop ( 4 , 'displayed default version text' ) return endif contains subroutine default_help () character ( len = :), allocatable :: cmd_name integer :: ilength call get_command_argument ( number = 0 , length = ilength ) if ( allocated ( cmd_name )) deallocate ( cmd_name ) allocate ( character ( len = ilength ) :: cmd_name ) call get_command_argument ( number = 0 , value = cmd_name ) G_passed_in = G_passed_in // repeat ( ' ' , len ( G_passed_in )) G_passed_in = replace_str ( G_passed_in , ' --' , NEW_LINE ( 'A' ) // ' --' ) if (. not . G_QUIET ) then call journal ( cmd_name , G_passed_in ) ! no help text, echo command and default options endif deallocate ( cmd_name ) end subroutine default_help end subroutine check_commandline !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_args(prototype,help_text,version_text,ierr,errmsg) !! !! character(len=*),intent(in),optional :: prototype !! character(len=*),intent(in),optional :: help_text(:) !! character(len=*),intent(in),optional :: version_text(:) !! integer,intent(out),optional :: ierr !! character(len=:),intent(out),allocatable,optional :: errmsg !!##DESCRIPTION !! !! SET_ARGS(3f) requires a unix-like command prototype which defines !! the command-line options and their default values. When the program !! is executed this and the command-line options are applied and the !! resulting values are placed in an internal table for retrieval via !! GET_ARGS(3f). !! !! The built-in --help and --version options require optional help_text !! and version_text values to be provided to be particularly useful. !! !!##OPTIONS !! !! PROTOTYPE composed of all command arguments concatenated !! into a Unix-like command prototype string. For !! example: !! !! call set_args('-L F --ints 1,2,3 --title \"my title\" -R 10.3') !! !! The following options are predefined for all commands: !! '--verbose F --usage F --help F --version F'. !! !! see \"DEFINING THE PROTOTYPE\" in the next section for !! further details. !! !! HELP_TEXT if present, will be displayed when the program is called with !! a --help switch, and then the program will terminate. If !! help text is not supplied the command line initialization !! string will be echoed. !! !! VERSION_TEXT if present, any version text defined will be displayed !! when the program is called with a --version switch, !! and then the program will terminate. !! IERR if present a non-zero option is returned when an !! error occurs instead of the program terminating. !! ERRMSG a description of the error if ierr is present. !! !!##DEFINING THE PROTOTYPE !! !! o Keywords start with a single dash for short single-character !! keywords, and with two dashes for longer keywords. !! !! o all keywords on the prototype MUST get a value. !! !! * logicals must be set to an unquoted F. !! !! * strings must be delimited with double-quotes. !! Since internal double-quotes are represented with two !! double-quotes the string must be at least one space. !! !! o numeric keywords are not allowed; but this allows !! negative numbers to be used as values. !! !! o lists of values should be comma-delimited unless a !! user-specified delimiter is used. The prototype !! must use the same array delimiters as the call to !! get the value. !! !! o to define a zero-length allocatable array make the !! value a delimiter (usually a comma) or an empty set !! of braces (\"[]\"). !! !! LONG AND SHORT NAMES !! !! Long keywords start with two dashes followed by more than one letter. !! Short keywords are a dash followed by a single letter. !! !! o It is recommended long names (--keyword) should be all lowercase !! but are case-sensitive by default, unless \"set_mode('ignorecase')\" !! is in effect. !! !! o Long names should always be more than one character. !! !! o The recommended way to have short names is to suffix the long !! name with :LETTER in the definition. !! !! If this syntax is used then logical shorts may be combined on the !! command line when \"set_mode('strict')\" is in effect. !! !! SPECIAL BEHAVIORS !! !! o A special behavior occurs if a keyword name ends in ::. !! When the program is called the next parameter is taken as !! a value even if it starts with -. This is not generally !! recommended but is useful in rare cases where non-numeric !! values starting with a dash are desired. !! !! o If the prototype ends with \"--\" a special mode is turned !! on where anything after \"--\" on input goes into the variable !! REMAINING with values double-quoted and also into the array ARGS !! instead of becoming elements in the UNNAMED array. This is not !! needed for normal processing, but was needed for a program that !! needed this behavior for its subcommands. !! !! That is, for a normal call all unnamed values go into UNNAMED !! and ARGS and REMAINING are ignored. So for !! !! call set_args('-x 10 -y 20 ') !! !! A program invocation such as !! !! xx a b c -- A B C \" dd \" !! !! results in !! !! UNNAMED= ['a','b','c','A','B','C',' dd'] !! REMAINING= '' !! ARGS= [character(len=0) :: ] ! ie, an empty character array !! !! Whereas !! !! call set_args('-x 10 -y 20 --') !! !! generates the following output from the same program execution: !! !! UNNAMED= ['a','b','c'] !! REMAINING= '\"A\" \"B\" \"C\" \" dd \"' !! ARGS= ['A','B','C,' dd'] !! !!##USAGE NOTES !! When invoking the program line note the (subject to change) !! following restrictions (which often differ between various !! command-line parsers): !! !! o values for duplicate keywords are appended together with a space !! separator when a command line is executed by default. !! !! o shuffling is not supported. Values immediately follow their !! keywords. !! !! o Only short Boolean keywords can be bundled together. !! If allowing bundling is desired call \"set_mode('strict')\". !! This will require prefixing long names with \"--\" and short !! names with \"-\". Otherwise M_CLI2 relaxes that requirement !! and mostly does not care what prefix is used for a keyword. !! But this would make it unclear what was meant by \"-ox\" if !! allowed options were \"-o F -x F --ox F \" for example, so !! \"strict\" mode is required to remove the ambiguity. !! !! o if a parameter value of just \"-\" is supplied it is !! converted to the string \"stdin\". !! !! o values not needed for a keyword value go into the character !! array \"UNNAMED\". !! !! In addition if the keyword \"--\" is encountered on the command !! line the rest of the command line goes into the character array !! \"UNNAMED\". !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_set_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! use M_CLI2, only : get_args_fixed_size !! implicit none !! integer :: i !! ! DEFINE ARGS !! real :: x, y, z !! real :: p(3) !! character(len=:),allocatable :: title !! logical :: l, lbig !! integer,allocatable :: ints(:) !! ! !! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) !! ! AND READ COMMAND LINE !! call set_args(' & !! ! reals !! & -x 1 -y 2.3 -z 3.4e2 & !! ! integer array !! & -p -1,-2,-3 & !! ! always double-quote strings !! & --title \"my title\" & !! ! string should be a single character at a minimum !! & --label \" \", & !! ! set all logical values to F !! & -l F -L F & !! ! set allocatable size to zero if you like by using a delimiter !! & --ints , & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! ! SCALARS !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args('l',l) !! call get_args('L',lbig) !! call get_args('ints',ints) ! ALLOCATABLE ARRAY !! call get_args('title',title) ! ALLOCATABLE STRING !! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'y=',y !! write(*,*)'z=',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'ints=',ints !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! ! UNNAMED VALUES !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_set_args !! !!##RESPONSE FILES !! !! If you have no interest in using external files as abbreviations !! you can ignore this section. Otherwise, before calling set_args(3f) !! add: !! !! use M_CLI2, only : set_mode !! call set_mode('response_file') !! !! M_CLI2 Response files are small files containing CLI (Command Line !! Interface) arguments that end with \".rsp\" that can be used when command !! lines are so long that they would exceed line length limits or so complex !! that it is useful to have a platform-independent method of creating !! an abbreviation. !! !! Shell aliases and scripts are often used for similar purposes (and !! allow for much more complex conditional execution, of course), but !! they generally cannot be used to overcome line length limits and are !! typically platform-specific. !! !! Examples of commands that support similar response files are the Clang !! and Intel compilers, although there is no standard format for the files. !! !! They are read if you add options of the syntax \"@NAME\" as the FIRST !! parameters on your program command line calls. They are not recursive -- !! that is, an option in a response file cannot be given the value \"@NAME2\" !! to call another response file. !! !! More than one response name may appear on a command line. !! !! They are case-sensitive names. !! !! Note \"@\" s a special character in Powershell, and requires being escaped !! with a grave character. !! !! LOCATING RESPONSE FILES !! !! A search for the response file always starts with the current directory. !! The search then proceeds to look in any additional directories specified !! with the colon-delimited environment variable CLI_RESPONSE_PATH. !! !! The first resource file found that results in lines being processed !! will be used and processing stops after that first match is found. If !! no match is found an error occurs and the program is stopped. !! !! RESPONSE FILE SECTIONS !! !! A simple response file just has options for calling the program in it !! prefixed with the word \"options\". !! But they can also contain section headers to denote selections that are !! only executed when a specific OS is being used, print messages, and !! execute system commands. !! !! SEARCHING FOR OSTYPE IN REGULAR FILES !! !! So assuming the name @NAME was specified on the command line a file !! named NAME.rsp will be searched for in all the search directories !! and then in that file a string that starts with the string @OSTYPE !! (if the environment variables $OS and $OSTYPE are not blank. $OSTYPE !! takes precedence over $OS). !! !! SEARCHING FOR UNLABELED DIRECTIVES IN REGULAR FILES !! !! Then, the same files will be searched for lines above any line starting !! with \"@\". That is, if there is no special section for the current OS !! it just looks at the top of the file for unlabeled options. !! !! SEARCHING FOR OSTYPE AND NAME IN THE COMPOUND FILE !! !! In addition or instead of files with the same name as the @NAME option !! on the command line, you can have one file named after the executable !! name that contains multiple abbreviation names. !! !! So if your program executable is named EXEC you create a single file !! called EXEC.rsp and can append all the simple files described above !! separating them with lines of the form @OSTYPE@NAME or just @NAME. !! !! So if no specific file for the abbreviation is found a file called !! \"EXEC.rsp\" is searched for where \"EXEC\" is the name of the executable. !! This file is always a \"compound\" response file that uses the following format: !! !! Any compound EXEC.rsp file found in the current or searched directories !! will be searched for the string @OSTYPE@NAME first. !! !! Then if nothing is found, the less specific line @NAME is searched for. !! !! THE SEARCH IS OVER !! !! Sounds complicated but actually works quite intuitively. Make a file in !! the current directory and put options in it and it will be used. If that !! file ends up needing different cases for different platforms add a line !! like \"@Linux\" to the file and some more lines and that will only be !! executed if the environment variable OSTYPE or OS is \"Linux\". If no match !! is found for named sections the lines at the top before any \"@\" lines !! will be used as a default if no match is found. !! !! If you end up using a lot of files like this you can combine them all !! together and put them into a file called \"program_name\".rsp and just !! put lines like @NAME or @OSTYPE@NAME at that top of each selection. !! !! Now, back to the details on just what you can put in the files. !! !!##SPECIFICATION FOR RESPONSE FILES !! !! SIMPLE RESPONSE FILES !! !! The first word of a line is special and has the following meanings: !! !! options|- Command options following the rules of the SET_ARGS(3f) !! prototype. So !! o It is preferred to specify a value for all options. !! o double-quote strings. !! o give a blank string value as \" \". !! o use F|T for lists of logicals, !! o lists of numbers should be comma-delimited. !! o --usage, --help, --version, --verbose, and unknown !! options are ignored. !! !! comment|# Line is a comment line !! system|! System command. !! System commands are executed as a simple call to !! system (so a cd(1) or setting a shell variable !! would not effect subsequent lines, for example) !! BEFORE the command being processed. !! print|> Message to screen !! stop display message and stop program. !! !! NOTE: system commands are executed when encountered, but options are !! gathered from multiple option lines and passed together at the end of !! processing of the block; so all commands will be executed BEFORE the !! command for which options are being supplied no matter where they occur. !! !! So if a program that does nothing but echos its parameters !! !! program testit !! use M_CLI2, only : set_args, rget, sget, lget, set_mode !! implicit none !! real :: x,y ; namelist/args/ x,y !! character(len=:),allocatable :: title ; namelist/args/ title !! logical :: big ; namelist/args/ big !! call set_mode('response_file') !! call set_args('-x 10.0 -y 20.0 --title \"my title\" --big F') !! x=rget('x') !! y=rget('y') !! title=sget('title') !! big=lget('big') !! write(*,nml=args) !! end program testit !! !! And a file in the current directory called \"a.rsp\" contains !! !! # defaults for project A !! options -x 1000 -y 9999 !! options --title \" \" !! options --big T !! !! The program could be called with !! !! $myprog # normal call !! X=10.0 Y=20.0 TITLE=\"my title\" !! !! $myprog @a # change defaults as specified in \"a.rsp\" !! X=1000.0 Y=9999.0 TITLE=\" \" !! !! # change defaults but use any option as normal to override defaults !! $myprog @a -y 1234 !! X=1000.0 Y=1234.0 TITLE=\" \" !! !! COMPOUND RESPONSE FILES !! !! A compound response file has the same basename as the executable with a !! \".rsp\" suffix added. So if your program is named \"myprg\" the filename !! must be \"myprg.rsp\". !! !! Note that here `basename` means the last leaf of the !! name of the program as returned by the Fortran intrinsic !! GET_COMMAND_ARGUMENT(0,...) trimmed of anything after a period (\".\"), !! so it is a good idea not to use hidden files. !! !! Unlike simple response files compound response files can contain multiple !! setting names. !! !! Specifically in a compound file !! if the environment variable $OSTYPE (first) or $OS is set the first search !! will be for a line of the form (no leading spaces should be used): !! !! @OSTYPE@alias_name !! !! If no match or if the environment variables $OSTYPE and $OS were not !! set or a match is not found then a line of the form !! !! @alias_name !! !! is searched for in simple or compound files. If found subsequent lines !! will be ignored that start with \"@\" until a line not starting with !! \"@\" is encountered. Lines will then be processed until another line !! starting with \"@\" is found or end-of-file is encountered. !! !! COMPOUND RESPONSE FILE EXAMPLE !! An example compound file !! !! ################# !! @if !! > RUNNING TESTS USING RELEASE VERSION AND ifort !! options test --release --compiler ifort !! ################# !! @gf !! > RUNNING TESTS USING RELEASE VERSION AND gfortran !! options test --release --compiler gfortran !! ################# !! @nv !! > RUNNING TESTS USING RELEASE VERSION AND nvfortran !! options test --release --compiler nvfortran !! ################# !! @nag !! > RUNNING TESTS USING RELEASE VERSION AND nagfor !! options test --release --compiler nagfor !! # !! ################# !! # OS-specific example: !! @Linux@install !! # !! # install executables in directory (assuming install(1) exists) !! # !! system mkdir -p ~/.local/bin !! options run --release T --runner \"install -vbp -m 0711 -t ~/.local/bin\" !! @install !! STOP INSTALL NOT SUPPORTED ON THIS PLATFORM OR $OSTYPE NOT SET !! # !! ################# !! @fpm@testall !! # !! !fpm test --compiler nvfortran !! !fpm test --compiler ifort !! !fpm test --compiler gfortran !! !fpm test --compiler nagfor !! STOP tests complete. Any additional parameters were ignored !! ################# !! !! Would be used like !! !! fpm @install !! fpm @nag -- !! fpm @testall !! !! NOTES !! !! The intel Fortran compiler now calls the response files \"indirect !! files\" and does not add the implied suffix \".rsp\" to the files !! anymore. It also allows the @NAME syntax anywhere on the command line, !! not just at the beginning. -- 20201212 !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine set_args ( prototype , help_text , version_text , string , prefix , ierr , errmsg ) ! ident_1=\"@(#) M_CLI2 set_args(3f) parse prototype string\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: help_text (:) character ( len =* ), intent ( in ), optional :: version_text (:) character ( len =* ), intent ( in ), optional :: string character ( len =* ), intent ( in ), optional :: prefix integer , intent ( out ), optional :: ierr character ( len = :), intent ( out ), allocatable , optional :: errmsg character ( len = :), allocatable :: hold ! stores command line argument integer :: ibig character ( len = :), allocatable :: debug_mode debug_mode = upper ( get_env ( 'CLI_DEBUG_MODE' , 'FALSE' )) // ' ' select case ( debug_mode ( 1 : 1 )) case ( 'Y' , 'T' ) G_DEBUG = . true . end select G_response = CLI_RESPONSE_FILE G_options_only = . false . G_passed_in = '' G_STOP = 0 G_STOP_MESSAGE = '' if ( present ( prefix )) then G_PREFIX = prefix else G_PREFIX = '' endif if ( present ( ierr )) then G_QUIET = . true . else G_QUIET = . false . endif ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) call wipe_dictionary () hold = '--version F --usage F --help F --version F ' // adjustl ( prototype ) call prototype_and_cmd_args_to_nlist ( hold , string ) if ( allocated ( G_RESPONSE_IGNORED )) then if ( G_DEBUG ) write ( * , gen ) 'SET_ARGS:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED if ( size ( unnamed ) /= 0 ) write ( * , * ) 'LOGIC ERROR' call split ( G_RESPONSE_IGNORED , unnamed ) endif if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif if (. not . allocated ( args )) then allocate ( character ( len = 0 ) :: args ( 0 )) endif call check_commandline ( help_text , version_text ) ! process --help, --version, --usage if ( present ( ierr )) then ierr = G_STOP endif if ( present ( errmsg )) then errmsg = G_STOP_MESSAGE endif end subroutine set_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_subcommand(3f) - [ARGUMENTS:M_CLI2] special-case routine for !! handling subcommands on a command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function get_subcommand() !! !! character(len=:),allocatable :: get_subcommand !! !!##DESCRIPTION !! In the special case when creating a program with subcommands it !! is assumed the first word on the command line is the subcommand. A !! routine is required to handle response file processing, therefore !! this routine (optionally processing response files) returns that !! first word as the subcommand name. !! !! It should not be used by programs not building a more elaborate !! command with subcommands. !! !!##RETURNS !! NAME name of subcommand !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_subcommand !! !x! SUBCOMMANDS !! !x! For a command with subcommands like git(1) !! !x! you can make separate namelists for each subcommand. !! !x! You can call this program which has two subcommands (run, test), !! !x! like this: !! !x! demo_get_subcommand --help !! !x! demo_get_subcommand run -x -y -z --title -l -L !! !x! demo_get_subcommand test --title -l -L --testname !! !x! demo_get_subcommand run --help !! implicit none !! !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES !! real :: x=-999.0,y=-999.0,z=-999.0 !! character(len=80) :: title=\"not set\" !! logical :: l=.false. !! logical :: l_=.false. !! character(len=80) :: testname=\"not set\" !! character(len=20) :: name !! call parse(name) !x! DEFINE AND PARSE COMMAND LINE !! !x! ALL DONE CRACKING THE COMMAND LINE. !! !x! USE THE VALUES IN YOUR PROGRAM. !! write(*,*)'command was ',name !! write(*,*)'x,y,z .... ',x,y,z !! write(*,*)'title .... ',title !! write(*,*)'l,l_ ..... ',l,l_ !! write(*,*)'testname . ',testname !! contains !! subroutine parse(name) !! !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY !! use M_CLI2, only : set_args, get_args, get_args_fixed_length !! use M_CLI2, only : get_subcommand, set_mode !! character(len=*) :: name ! the subcommand name !! character(len=:),allocatable :: help_text(:), version_text(:) !! call set_mode('response_file') !! ! define version text !! version_text=[character(len=80) :: & !! '@(#)PROGRAM: demo_get_subcommand >', & !! '@(#)DESCRIPTION: My demo program >', & !! '@(#)VERSION: 1.0 20200715 >', & !! '@(#)AUTHOR: me, myself, and I>', & !! '@(#)LICENSE: Public Domain >', & !! '' ] !! ! general help for \"demo_get_subcommand --help\" !! help_text=[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L --title -x -y -z ', & !! ' * test -l -L --title ', & !! '' ] !! ! find the subcommand name by looking for first word on command !! ! not starting with dash !! name = get_subcommand() !! select case(name) !! case('run') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand \"run\" ', & !! ' ', & !! '' ] !! call set_args( & !! & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F',& !! & help_text,version_text) !! call get_args('x',x) !! call get_args('y',y) !! call get_args('z',z) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! case('test') !! help_text=[character(len=80) :: & !! ' ', & !! ' Help for subcommand \"test\" ', & !! ' ', & !! '' ] !! call set_args(& !! & '--title \"my title\" -l F -L F --testname \"Test\"',& !! & help_text,version_text) !! call get_args_fixed_length('title',title) !! call get_args('l',l) !! call get_args('L',l_) !! call get_args_fixed_length('testname',testname) !! case default !! ! process help and version !! call set_args(' ',help_text,version_text) !! write(*,'(*(a))')'unknown or missing subcommand [',trim(name),']' !! write(*,'(a)')[character(len=80) :: & !! ' allowed subcommands are ', & !! ' * run -l -L -title -x -y -z ', & !! ' * test -l -L -title ', & !! '' ] !! stop !! end select !! end subroutine parse !! end program demo_get_subcommand !! !!##AUTHOR !! John S. Urban, 2019 !! !!##LICENSE !! Public Domain !=================================================================================================================================== function get_subcommand () result ( sub ) ! ident_2=\"@(#) M_CLI2 get_subcommand(3f) parse prototype string to get subcommand allowing for response files\" character ( len = :), allocatable :: sub character ( len = :), allocatable :: cmdarg character ( len = :), allocatable :: array (:) character ( len = :), allocatable :: prototype integer :: ilongest integer :: i integer :: j G_subcommand = '' G_options_only = . true . sub = '' if (. not . allocated ( unnamed )) then allocate ( character ( len = 0 ) :: unnamed ( 0 )) endif ilongest = longest_command_argument () allocate ( character ( len = max ( 63 , ilongest )) :: cmdarg ) cmdarg (:) = '' ! look for @NAME if CLI_RESPONSE_FILE=.TRUE. AND LOAD THEM do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( scan ( adjustl ( cmdarg ( 1 : 1 )), '@' ) == 1 ) then call get_prototype ( cmdarg , prototype ) call split ( prototype , array ) ! assume that if using subcommands first word not starting with dash is the subcommand do j = 1 , size ( array ) if ( adjustl ( array ( j )( 1 : 1 )) /= '-' ) then G_subcommand = trim ( array ( j )) sub = G_subcommand exit endif enddo endif enddo if ( G_subcommand /= '' ) then sub = G_subcommand elseif ( size ( unnamed ) /= 0 ) then sub = unnamed ( 1 ) else cmdarg (:) = '' do i = 1 , command_argument_count () call get_command_argument ( i , cmdarg ) if ( adjustl ( cmdarg ( 1 : 1 )) /= '-' ) then sub = trim ( cmdarg ) exit endif enddo endif G_options_only = . false . end function get_subcommand !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_usage(3f) - [ARGUMENTS:M_CLI2] allow setting a short description !! for keywords for the --usage switch !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_usage(keyword,description) !! !! character(len=*),intent(in) :: keyword !! character(len=*),intent(in) :: description !! !!##DESCRIPTION !! !!##OPTIONS !! KEYWORD the name of a command keyword !! DESCRIPTION a brief one-line description of the keyword !! !! !!##EXAMPLE !! !! sample program: !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine set_usage ( keyword , description , value ) character ( len =* ), intent ( in ) :: keyword character ( len =* ), intent ( in ) :: description character ( len =* ), intent ( in ) :: value write ( * , * ) keyword write ( * , * ) description write ( * , * ) value ! store the descriptions in an array and then apply them when set_args(3f) is called. ! alternatively, could allow for a value as well in lieu of the prototype end subroutine set_usage !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command !! and store tokens into dictionary !! (LICENSE:PD) !! !!##SYNOPSIS !! !! recursive subroutine prototype_to_dictionary(string) !! !! character(len=*),intent(in) :: string !! !!##DESCRIPTION !! given a string of form !! !! -var value -var value !! !! define dictionary of form !! !! keyword(i), value(i) !! !! o string values !! !! o must be delimited with double quotes. !! o adjacent double quotes put one double quote into value !! o must not be null. A blank is specified as \" \", not \"\". !! !! o logical values !! !! o logical values must have a value. Use F. !! !! o leading and trailing blanks are removed from unquoted values !! !! !!##OPTIONS !! STRING string is character input string to define command !! !!##RETURNS !! !!##EXAMPLE !! !! sample program: !! !! call prototype_to_dictionary(' -l F --ignorecase F --title \"my title string\" -x 10.20') !! call prototype_to_dictionary(' --ints 1,2,3,4') !! !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== recursive subroutine prototype_to_dictionary ( string ) ! ident_3=\"@(#) M_CLI2 prototype_to_dictionary(3f) parse user command and store tokens into dictionary\" character ( len =* ), intent ( in ) :: string ! string is character input string of options and values character ( len = :), allocatable :: dummy ! working copy of string character ( len = :), allocatable :: value character ( len = :), allocatable :: keyword character ( len = 3 ) :: delmt ! flag if in a delimited string or not character ( len = 1 ) :: currnt ! current character being processed character ( len = 1 ) :: prev ! character to left of CURRNT character ( len = 1 ) :: forwrd ! character to right of CURRNT integer , dimension ( 2 ) :: ipnt integer :: islen ! number of characters in input string integer :: ipoint integer :: itype integer , parameter :: VAL = 1 , KEYW = 2 integer :: ifwd integer :: ibegin integer :: iend integer :: place islen = len_trim ( string ) ! find number of characters in input string if ( islen == 0 ) then ! if input string is blank, even default variable will not be changed return endif dummy = adjustl ( string ) // ' ' keyword = \"\" ! initial variable name value = \"\" ! initial value of a string ipoint = 0 ! ipoint is the current character pointer for (dummy) ipnt ( 2 ) = 2 ! pointer to position in keyword ipnt ( 1 ) = 1 ! pointer to position in value itype = VAL ! itype=1 for value, itype=2 for variable delmt = \"off\" prev = \" \" G_keyword_single_letter = . true . do ipoint = ipoint + 1 ! move current character pointer forward currnt = dummy ( ipoint : ipoint ) ! store current character into currnt ifwd = min ( ipoint + 1 , islen ) ! ensure not past end of string forwrd = dummy ( ifwd : ifwd ) ! next character (or duplicate if last) if (( currnt == \"-\" . and . prev == \" \" . and . delmt == \"off\" . and . index ( \"0123456789.\" , forwrd ) == 0 ). or . ipoint > islen ) then ! beginning of a keyword if ( forwrd == '-' ) then ! change --var to -var so \"long\" syntax is supported !x!dummy(ifwd:ifwd)='_' ipoint = ipoint + 1 ! ignore second - instead (was changing it to _) G_keyword_single_letter = . false . ! flag this is a long keyword else G_keyword_single_letter = . true . ! flag this is a short (single letter) keyword endif if ( ipnt ( 1 ) - 1 >= 1 ) then ! position in value ibegin = 1 iend = len_trim ( value (: ipnt ( 1 ) - 1 )) TESTIT : do if ( iend == 0 ) then ! len_trim returned 0, value is blank iend = ibegin exit TESTIT elseif ( value ( ibegin : ibegin ) == \" \" ) then ibegin = ibegin + 1 else exit TESTIT endif enddo TESTIT if ( keyword /= ' ' ) then if ( value == '[]' ) value = ',' call update ( keyword , value ) ! store name and its value elseif ( G_remaining_option_allowed ) then ! meaning \"--\" has been encountered if ( value == '[]' ) value = ',' call update ( '_args_' , trim ( value )) else !x!write(warn,'(*(g0))')'*prototype_to_dictionary* warning: ignoring string [',trim(value),'] for ',trim(keyword) G_RESPONSE_IGNORED = TRIM ( VALUE ) if ( G_DEBUG ) write ( * , gen ) 'PROTOTYPE_TO_DICTIONARY:G_RESPONSE_IGNORED:' , G_RESPONSE_IGNORED endif else call locate_key ( keyword , place ) if ( keyword /= ' ' . and . place < 0 ) then call update ( keyword , 'F' ) ! store name and null value (first pass) elseif ( keyword /= ' ' ) then call update ( keyword , ' ' ) ! store name and null value (second pass) elseif (. not . G_keyword_single_letter . and . ipoint - 2 == islen ) then ! -- at end of line G_remaining_option_allowed = . true . ! meaning for \"--\" is that everything on commandline goes into G_remaining endif endif itype = KEYW ! change to expecting a keyword value = \"\" ! clear value for this variable keyword = \"\" ! clear variable name ipnt ( 1 ) = 1 ! restart variable value ipnt ( 2 ) = 1 ! restart variable name else ! currnt is not one of the special characters ! the space after a keyword before the value if ( currnt == \" \" . and . itype == KEYW ) then ! switch from building a keyword string to building a value string itype = VAL ! beginning of a delimited value elseif ( currnt == \"\"\"\" . and . itype == VAL ) then ! second of a double quote, put quote in if ( prev == \"\"\"\" ) then if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 delmt = \"on\" elseif ( delmt == \"on\" ) then ! first quote of a delimited string delmt = \"off\" else delmt = \"on\" endif if ( prev /= \"\"\"\" ) then ! leave quotes where found them if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 endif else ! add character to current keyword or value if ( itype == VAL ) then value = value // currnt else keyword = keyword // currnt endif ipnt ( itype ) = ipnt ( itype ) + 1 endif endif prev = currnt if ( ipoint <= islen ) then cycle else exit endif enddo end subroutine prototype_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present !! on command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! elemental impure function specified(name) !! !! character(len=*),intent(in) :: name !! logical :: specified !! !!##DESCRIPTION !! !! specified(3f) returns .true. if the specified keyword was present on !! the command line. !! !! M_CLI2 intentionally does not have validators except for SPECIFIED(3f) !! and of course a check whether the input conforms to the type when !! requesting a value (with get_args(3f) or the convenience functions !! like inum(3f)). !! !! Fortran already has powerful validation capabilities. Logical !! expressions ANY(3f) and ALL(3f) are standard Fortran features which !! easily allow performing the common validations for command line !! arguments without having to learn any additional syntax or methods. !! !!##OPTIONS !! !! NAME name of commandline argument to query the presence of. Long !! names should always be used. !! !!##RETURNS !! SPECIFIED returns .TRUE. if specified NAME was present on the command !! line when the program was invoked. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_specified !! use, intrinsic :: iso_fortran_env, only : & !! & stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT !! use M_CLI2, only : set_args, igets, rgets, specified, sget, lget !! implicit none !! !! ! Define args !! integer,allocatable :: ints(:) !! real,allocatable :: floats(:) !! logical :: flag !! character(len=:),allocatable :: color !! character(len=:),allocatable :: list(:) !! integer :: i !! !! call set_args('& !! & --color:c \"red\" & !! & --flag:f F & !! & --ints:i 1,10,11 & !! & --floats:T 12.3, 4.56 & !! & ') !! ints=igets('ints') !! floats=rgets('floats') !! flag=lget('flag') !! color=sget('color') !! !! write(*,*)'color=',color !! write(*,*)'flag=',flag !! write(*,*)'ints=',ints !! write(*,*)'floats=',floats !! !! write(*,*)'was -flag specified?',specified('flag') !! !! ! elemental !! write(*,*)specified(['floats','ints ']) !! !! ! If you want to know if groups of parameters were specified use !! ! ANY(3f) and ALL(3f) !! write(*,*)'ANY:',any(specified(['floats','ints '])) !! write(*,*)'ALL:',all(specified(['floats','ints '])) !! !! ! For mutually exclusive !! if (all(specified(['floats','ints '])))then !! write(*,*)'You specified both names --ints and --floats' !! endif !! !! ! For required parameter !! if (.not.any(specified(['floats','ints '])))then !! write(*,*)'You must specify --ints or --floats' !! endif !! !! ! check if all values are in range from 10 to 30 and even !! write(*,*)'are all numbers good?',all([ints >= 10,ints <= 30,(ints/2)*2 == ints]) !! !! ! perhaps you want to check one value at a time !! do i=1,size(ints) !! write(*,*)ints(i),[ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)] !! if(all([ints(i) >= 10,ints(i) <= 30,(ints(i)/2)*2 == ints(i)]) )then !! write(*,*)ints(i),'is an even number from 10 to 30 inclusive' !! else !! write(*,*)ints(i),'is not an even number from 10 to 30 inclusive' !! endif !! enddo !! !! list = [character(len=10) :: 'red','white','blue'] !! if( any(color == list) )then !! write(*,*)color,'matches a value in the list' !! else !! write(*,*)color,'not in the list' !! endif !! !! if(size(ints).eq.3)then !! write(*,*)'ints(:) has expected number of values' !! else !! write(*,*)'ints(:) does not have expected number of values' !! endif !! !! end program demo_specified !! !! Default output !! !! > color=red !! > flag= F !! > ints= 1 10 11 !! > floats= 12.3000002 4.55999994 !! > was -flag specified? F !! > F F !! > ANY: F !! > ALL: F !! > You must specify --ints or --floats !! > 1 F T F !! > 1 is not an even number from 10 to 30 inclusive !! > 10 T T T !! > 10 is an even number from 10 to 30 inclusive !! > 11 T T F !! > 11 is not an even number from 10 to 30 inclusive !! > red matches a value in the list !! > ints(:) has expected number of values !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure function specified ( key ) character ( len =* ), intent ( in ) :: key logical :: specified integer :: place call locate_key ( key , place ) ! find where string is or should be if ( place < 1 ) then specified = . false . else specified = present_in ( place ) endif end function specified !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given !! keyword and value !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine update(key,val) !! !! character(len=*),intent(in) :: key !! character(len=*),intent(in),optional :: val !!##DESCRIPTION !! Update internal dictionary in M_CLI2(3fm) module. !!##OPTIONS !! key name of keyword to add, replace, or delete from dictionary !! val if present add or replace value associated with keyword. If not !! present remove keyword entry from dictionary. !! !! If \"present\" is true, a value will be appended !!##EXAMPLE !! !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine update ( key , val ) character ( len =* ), intent ( in ) :: key character ( len =* ), intent ( in ), optional :: val integer :: place , ii integer :: iilen character ( len = :), allocatable :: val_local character ( len = :), allocatable :: short character ( len = :), allocatable :: long character ( len = :), allocatable :: long_short (:) integer :: isize logical :: set_mandatory set_mandatory = . false . call split ( trim ( key ), long_short , ':' , nulls = 'return' ) ! split long:short keyword or long:short:: or long:: or short:: ! check for :: on end isize = size ( long_short ) if ( isize > 0 ) then ! very special-purpose syntax where if ends in :: next field is a value even if ( long_short ( isize ) == '' ) then ! if it starts with a dash, for --flags option on fpm(1). set_mandatory = . true . long_short = long_short (: isize - 1 ) endif endif select case ( size ( long_short )) case ( 0 ) long = '' short = '' case ( 1 ) long = trim ( long_short ( 1 )) if ( len_trim ( long ) == 1 ) then !x!ii= findloc (shorts, long, dim=1) ! if parsing arguments on line and a short keyword look up long value ii = maxloc ([ 0 , merge ( 1 , 0 , shorts == long )], dim = 1 ) if ( ii > 1 ) then long = keywords ( ii - 1 ) endif short = long else short = '' endif case ( 2 ) long = trim ( long_short ( 1 )) short = trim ( long_short ( 2 )) case default write ( warn , * ) 'WARNING: incorrect syntax for key: ' , trim ( key ) long = trim ( long_short ( 1 )) short = trim ( long_short ( 2 )) end select if ( G_UNDERDASH ) long = replace_str ( long , '-' , '_' ) if ( G_NOSEPARATOR ) then long = replace_str ( long , '-' , '' ) long = replace_str ( long , '_' , '' ) endif if ( G_IGNORECASE . and . len_trim ( long ) > 1 ) long = lower ( long ) if ( present ( val )) then val_local = val iilen = len_trim ( val_local ) call locate_key ( long , place ) ! find where string is or should be if ( place < 1 ) then ! if string was not found insert it call insert_ ( keywords , long , iabs ( place )) call insert_ ( values , val_local , iabs ( place )) call insert_ ( counts , iilen , iabs ( place )) call insert_ ( shorts , short , iabs ( place )) call insert_ ( present_in ,. true ., iabs ( place )) call insert_ ( mandatory , set_mandatory , iabs ( place )) else if ( present_in ( place )) then ! if multiple keywords append values with space between them if ( G_append ) then if ( values ( place )( 1 : 1 ) == '\"' ) then ! UNDESIRABLE: will ignore previous blank entries val_local = '\"' // trim ( unquote ( values ( place ))) // ' ' // trim ( unquote ( val_local )) // '\"' else val_local = values ( place ) // ' ' // val_local endif endif iilen = len_trim ( val_local ) endif call replace_ ( values , val_local , place ) call replace_ ( counts , iilen , place ) call replace_ ( present_in ,. true ., place ) endif else ! if no value is present remove the keyword and related values call locate_key ( long , place ) ! check name as long and short if ( place > 0 ) then call remove_ ( keywords , place ) call remove_ ( values , place ) call remove_ ( counts , place ) call remove_ ( shorts , place ) call remove_ ( present_in , place ) call remove_ ( mandatory , place ) endif endif end subroutine update !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! wipe_dictionary(3fp) - [ARGUMENTS:M_CLI2] reset private M_CLI2(3fm) !! dictionary to empty !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine wipe_dictionary() !!##DESCRIPTION !! reset private M_CLI2(3fm) dictionary to empty !!##EXAMPLE !! !! Sample program: !! !! program demo_wipe_dictionary !! use M_CLI2, only : dictionary !! call wipe_dictionary() !! end program demo_wipe_dictionary !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine wipe_dictionary () if ( allocated ( keywords )) deallocate ( keywords ) allocate ( character ( len = 0 ) :: keywords ( 0 )) if ( allocated ( values )) deallocate ( values ) allocate ( character ( len = 0 ) :: values ( 0 )) if ( allocated ( counts )) deallocate ( counts ) allocate ( counts ( 0 )) if ( allocated ( shorts )) deallocate ( shorts ) allocate ( character ( len = 0 ) :: shorts ( 0 )) if ( allocated ( present_in )) deallocate ( present_in ) allocate ( present_in ( 0 )) if ( allocated ( mandatory )) deallocate ( mandatory ) allocate ( mandatory ( 0 )) end subroutine wipe_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with !! key name in private M_CLI2(3fm) dictionary !!##SYNOPSIS !! !! !!##DESCRIPTION !! Get dictionary value associated with key name in private M_CLI2(3fm) !! dictionary. !!##OPTIONS !!##RETURNS !!##EXAMPLE !! !=================================================================================================================================== function get ( key ) result ( valout ) character ( len =* ), intent ( in ) :: key character ( len = :), allocatable :: valout integer :: place ! find where string is or should be call locate_key ( key , place ) if ( place < 1 ) then valout = '' else valout = values ( place )(: counts ( place )) endif end function get !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert !! Unix-like command arguments to table !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine prototype_and_cmd_args_to_nlist(prototype) !! !! character(len=*) :: prototype !!##DESCRIPTION !! create dictionary with character keywords, values, and value lengths !! using the routines for maintaining a list from command line arguments. !!##OPTIONS !! prototype !!##EXAMPLE !! !! Sample program !! !! program demo_prototype_and_cmd_args_to_nlist !! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed !! implicit none !! character(len=:),allocatable :: readme !! character(len=256) :: message !! integer :: ios !! integer :: i !! doubleprecision :: something !! !! ! define arguments !! logical :: l,h,v !! real :: p(2) !! complex :: c !! doubleprecision :: x,y,z !! !! ! uppercase keywords get an underscore to make it easier to remember !! logical :: l_,h_,v_ !! ! character variables must be long enough to hold returned value !! character(len=256) :: a_,b_ !! integer :: c_(3) !! !! ! give command template with default values !! ! all values except logicals get a value. !! ! strings must be delimited with double quotes !! ! A string has to have at least one character as for -A !! ! lists of numbers should be comma-delimited. !! ! No spaces are allowed in lists of numbers !! call prototype_and_cmd_args_to_nlist('& !! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & !! & -A \" \" -B \"Value B\" -C 10,20,30 -c (-123,-456)',readme) !! !! call get_args('x',x,'y',y,'z',z) !! something=sqrt(x**2+y**2+z**2) !! write (*,*)something,x,y,z !! if(size(unnamed) > 0)then !! write (*,'(a)')'files:' !! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) !! endif !! end program demo_prototype_and_cmd_args_to_nlist !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine prototype_and_cmd_args_to_nlist ( prototype , string ) ! ident_4=\"@(#) M_CLI2 prototype_and_cmd_args_to_nlist create dictionary from prototype if not null and update from command line\" character ( len =* ), intent ( in ) :: prototype character ( len =* ), intent ( in ), optional :: string integer :: ibig integer :: itrim integer :: iused if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:START' G_passed_in = prototype ! make global copy for printing ibig = longest_command_argument () ! bug in gfortran. len=0 should be fine ibig = max ( ibig , 1 ) IF ( ALLOCATED ( UNNAMED )) DEALLOCATE ( UNNAMED ) ALLOCATE ( CHARACTER ( LEN = IBIG ) :: UNNAMED ( 0 )) if ( allocated ( args )) deallocate ( args ) allocate ( character ( len = ibig ) :: args ( 0 )) G_remaining_option_allowed = . false . G_remaining_on = . false . G_remaining = '' if ( prototype /= '' ) then call prototype_to_dictionary ( prototype ) ! build dictionary from prototype ! if short keywords not used by user allow them for standard options call locate_key ( 'h' , iused ) if ( iused <= 0 ) then call update ( 'help' ) call update ( 'help:h' , 'F' ) endif call locate_key ( 'v' , iused ) if ( iused <= 0 ) then call update ( 'version' ) call update ( 'version:v' , 'F' ) endif call locate_key ( 'V' , iused ) if ( iused <= 0 ) then call update ( 'verbose' ) call update ( 'verbose:V' , 'F' ) endif call locate_key ( 'u' , iused ) if ( iused <= 0 ) then call update ( 'usage' ) call update ( 'usage:u' , 'F' ) endif present_in = . false . ! reset all values to false so everything gets written endif if ( present ( string )) then ! instead of command line arguments use another prototype string if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:CALL PROTOTYPE_TO_DICTIONARY:STRING=' , STRING call prototype_to_dictionary ( string ) ! build dictionary from prototype else if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:CALL CMD_ARGS_TO_DICTIONARY:CHECK=' ,. true . call cmd_args_to_dictionary () endif if ( len ( G_remaining ) > 1 ) then ! if -- was in prototype then after -- on input return rest in this string itrim = len ( G_remaining ) if ( G_remaining ( itrim : itrim ) == ' ' ) then ! was adding a space at end as building it, but do not want to remove blanks G_remaining = G_remaining (: itrim - 1 ) endif remaining = G_remaining endif if ( G_DEBUG ) write ( * , gen ) 'CMD_ARGS_TO_NLIST:NORMAL END' end subroutine prototype_and_cmd_args_to_nlist !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine expand_response ( name ) character ( len =* ), intent ( in ) :: name character ( len = :), allocatable :: prototype logical :: hold if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:START:NAME=' , name call get_prototype ( name , prototype ) if ( prototype /= '' ) then hold = G_append G_append = . false . if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:CALL PROTOTYPE_TO_DICTIONARY:PROTOTYPE=' , prototype call prototype_to_dictionary ( prototype ) ! build dictionary from prototype G_append = hold endif if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:END' end subroutine expand_response !=================================================================================================================================== subroutine get_prototype ( name , prototype ) ! process @name abbreviations character ( len =* ), intent ( in ) :: name character ( len = :), allocatable , intent ( out ) :: prototype character ( len = :), allocatable :: filename character ( len = :), allocatable :: os character ( len = :), allocatable :: plain_name character ( len = :), allocatable :: search_for integer :: lun integer :: ios integer :: itrim character ( len = 4096 ) :: line !x! assuming input never this long character ( len = 256 ) :: message character ( len = :), allocatable :: array (:) ! output array of tokens integer :: lines_processed lines_processed = 0 plain_name = name // ' ' plain_name = trim ( name ( 2 :)) os = '@' // get_env ( 'OSTYPE' , get_env ( 'OS' )) if ( G_DEBUG ) write ( * , gen ) 'GET_PROTOTYPE:OS=' , OS search_for = '' ! look for NAME.rsp and see if there is an @OS section in it and position to it and read if ( os /= '@' ) then search_for = os call find_and_read_response_file ( plain_name ) if ( lines_processed /= 0 ) return endif ! look for NAME.rsp and see if there is anything before an OS-specific section search_for = '' call find_and_read_response_file ( plain_name ) if ( lines_processed /= 0 ) return ! look for ARG0.rsp with @OS@NAME section in it and position to it if ( os /= '@' ) then search_for = os // name call find_and_read_response_file ( basename ( get_name (), suffix = . false .)) if ( lines_processed /= 0 ) return endif ! look for ARG0.rsp with a section called @NAME in it and position to it search_for = name call find_and_read_response_file ( basename ( get_name (), suffix = . false .)) if ( lines_processed /= 0 ) return write ( * , gen ) ' response name [' // trim ( name ) // '] not found' stop 1 contains !=================================================================================================================================== subroutine find_and_read_response_file ( rname ) ! search for a simple file named the same as the @NAME field with one entry assumed in it character ( len =* ), intent ( in ) :: rname character ( len = :), allocatable :: paths (:) character ( len = :), allocatable :: testpath character ( len = 256 ) :: message integer :: i integer :: ios prototype = '' ! look for NAME.rsp ! assume if have / or \\ a full filename was supplied to support ifort(1) if (( index ( rname , '/' ) /= 0. or . index ( rname , '\\') /= 0) .and. len(rname) > 1 )then filename=rname lun=fileopen(filename,message) if(lun /= -1)then call process_response() close(unit=lun,iostat=ios) endif return else filename=rname//' . rsp ' endif if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : FILENAME = ',filename ! look for name.rsp in directories from environment variable assumed to be a colon-separated list of directories call split(get_env(' CLI_RESPONSE_PATH ',' ~ / . local / share / rsp '),paths) paths=[character(len=len(paths)) :: ' ',paths] if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : PATHS = ',paths do i=1,size(paths) testpath=join_path(paths(i),filename) lun=fileopen(testpath,message) if(lun /= -1)then if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : SEARCH_FOR = ',search_for if(search_for /= '') call position_response() ! set to end of file or where string was found call process_response() if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : LINES_PROCESSED = ',LINES_PROCESSED close(unit=lun,iostat=ios) if(G_DEBUG)write(*,gen)' < DEBUG > FIND_AND_READ_RESPONSE_FILE : CLOSE : LUN = ',LUN,' IOSTAT = ',IOS if(lines_processed /= 0)exit endif enddo end subroutine find_and_read_response_file !=================================================================================================================================== subroutine position_response() integer :: ios line='' INFINITE: do read(unit=lun,fmt=' ( a ) ',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then if(G_DEBUG)write(*,gen)' < DEBUG > POSITION_RESPONSE : EOF ' backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)' < ERROR >* position_response * : '//trim(message) exit INFINITE endif line=adjustl(line) if(line == search_for)return enddo INFINITE end subroutine position_response !=================================================================================================================================== subroutine process_response() character(len=:),allocatable :: padded character(len=:),allocatable :: temp line='' lines_processed=0 INFINITE: do read(unit=lun,fmt=' ( a ) ',iostat=ios,iomsg=message)line if(is_iostat_end(ios))then backspace(lun,iostat=ios) exit INFINITE elseif(ios /= 0)then write(*,gen)' < ERROR >* process_response * : '//trim(message) exit INFINITE endif line=trim(adjustl(line)) temp=line if(index(temp//' ',' # ') == 1)cycle if(temp /= '')then if(index(temp,' @ ') == 1.and.lines_processed /= 0)exit INFINITE call split(temp,array) ! get first word itrim=len_trim(array(1))+2 temp=temp(itrim:) PROCESS: select case(lower(array(1))) case(' comment ',' # ','') case(' system ',' !','$') if ( G_options_only ) exit PROCESS lines_processed = lines_processed + 1 call execute_command_line ( temp ) case ( 'options' , 'option' , '-' ) lines_processed = lines_processed + 1 prototype = prototype // ' ' // trim ( temp ) case ( 'print' , '>' , 'echo' ) if ( G_options_only ) exit PROCESS lines_processed = lines_processed + 1 write ( * , '(a)' ) trim ( temp ) case ( 'stop' ) if ( G_options_only ) exit PROCESS write ( * , '(a)' ) trim ( temp ) stop case default if ( array ( 1 )( 1 : 1 ) == '-' ) then ! assume these are simply options to support ifort(1) ! if starts with a single dash must assume a single argument ! and rest is value to support -Dname and -Ifile option ! which currently is not supported, so multiple short keywords ! does not work. Just a ifort(1) test at this point, so do not document if ( G_options_only ) exit PROCESS padded = trim ( line ) // ' ' if ( padded ( 2 : 2 ) == '-' ) then prototype = prototype // ' ' // trim ( line ) else prototype = prototype // ' ' // padded ( 1 : 2 ) // ' ' // trim ( padded ( 3 :)) endif lines_processed = lines_processed + 1 else if ( array ( 1 )( 1 : 1 ) == '@' ) cycle INFINITE !skip adjacent @ lines from first lines_processed = lines_processed + 1 write ( * , '(*(g0))' ) 'unknown response keyword [' , array ( 1 ), '] with options of [' , trim ( temp ), ']' endif end select PROCESS endif enddo INFINITE end subroutine process_response end subroutine get_prototype !=================================================================================================================================== function fileopen ( filename , message ) result ( lun ) character ( len =* ), intent ( in ) :: filename character ( len =* ), intent ( out ), optional :: message integer :: lun integer :: ios character ( len = 256 ) :: message_local ios = 0 message_local = '' open ( file = filename , newunit = lun ,& & form = 'formatted' , access = 'sequential' , action = 'read' ,& & position = 'rewind' , status = 'old' , iostat = ios , iomsg = message_local ) if ( ios /= 0 ) then lun =- 1 if ( present ( message )) then message = trim ( message_local ) else write ( * , gen ) trim ( message_local ) endif endif if ( G_DEBUG ) write ( * , gen ) 'FILEOPEN:FILENAME=' , filename , ' LUN=' , lun , ' IOS=' , IOS , ' MESSAGE=' , trim ( message_local ) end function fileopen !=================================================================================================================================== function get_env ( NAME , DEFAULT ) result ( VALUE ) character ( len =* ), intent ( in ) :: NAME character ( len =* ), intent ( in ), optional :: DEFAULT character ( len = :), allocatable :: VALUE integer :: howbig integer :: stat integer :: length ! get length required to hold value length = 0 if ( NAME /= '' ) then call get_environment_variable ( NAME , length = howbig , status = stat , trim_name = . true .) select case ( stat ) case ( 1 ) !x!print *, NAME, \" is not defined in the environment. Strange...\" VALUE = '' case ( 2 ) !x!print *, \"This processor doesn't support environment variables. Boooh!\" VALUE = '' case default ! make string to hold value of sufficient size if ( allocated ( value )) deallocate ( value ) allocate ( character ( len = max ( howbig , 1 )) :: VALUE ) ! get value call get_environment_variable ( NAME , VALUE , status = stat , trim_name = . true .) if ( stat /= 0 ) VALUE = '' end select else VALUE = '' endif if ( VALUE == '' . and . present ( DEFAULT )) VALUE = DEFAULT end function get_env !=================================================================================================================================== function join_path ( a1 , a2 , a3 , a4 , a5 ) result ( path ) ! Construct path by joining strings with os file separator ! character ( len =* ), intent ( in ) :: a1 , a2 character ( len =* ), intent ( in ), optional :: a3 , a4 , a5 character ( len = :), allocatable :: path character ( len = 1 ) :: filesep filesep = separator () if ( a1 /= '' ) then path = trim ( a1 ) // filesep // trim ( a2 ) else path = trim ( a2 ) endif if ( present ( a3 )) path = path // filesep // trim ( a3 ) if ( present ( a4 )) path = path // filesep // trim ( a4 ) if ( present ( a5 )) path = path // filesep // trim ( a5 ) path = adjustl ( path // ' ' ) path = path ( 1 : 1 ) // replace_str ( path , filesep // filesep , '' ) ! some systems allow names starting with '//' or '\\\\' path = trim ( path ) end function join_path !=================================================================================================================================== function get_name () result ( name ) ! get the pathname of arg0 character ( len = :), allocatable :: arg0 integer :: arg0_length integer :: istat character ( len = 4096 ) :: long_name character ( len = :), allocatable :: name arg0_length = 0 name = '' long_name = '' call get_command_argument ( 0 , length = arg0_length , status = istat ) if ( istat == 0 ) then if ( allocated ( arg0 )) deallocate ( arg0 ) allocate ( character ( len = arg0_length ) :: arg0 ) call get_command_argument ( 0 , arg0 , status = istat ) if ( istat == 0 ) then inquire ( file = arg0 , iostat = istat , name = long_name ) name = trim ( long_name ) else name = arg0 endif endif end function get_name !=================================================================================================================================== function basename ( path , suffix ) result ( base ) ! Extract filename from path with/without suffix ! character ( * ), intent ( In ) :: path logical , intent ( in ), optional :: suffix character (:), allocatable :: base character (:), allocatable :: file_parts (:) logical :: with_suffix if (. not . present ( suffix )) then with_suffix = . true . else with_suffix = suffix endif if ( with_suffix ) then call split ( path , file_parts , delimiters = '\\/' ) if ( size ( file_parts ) > 0 ) then base = trim ( file_parts ( size ( file_parts ))) else base = '' endif else call split ( path , file_parts , delimiters = '\\/.' ) if ( size ( file_parts ) >= 2 ) then base = trim ( file_parts ( size ( file_parts ) - 1 )) elseif ( size ( file_parts ) == 1 ) then base = trim ( file_parts ( 1 )) else base = '' endif endif end function basename !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function separator () result ( sep ) !> !!##NAME !! separator(3f) - [M_io:ENVIRONMENT] try to determine pathname directory separator character !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function separator() result(sep) !! !! character(len=1) :: sep !! !!##DESCRIPTION !! First testing for the existence of \"/.\", then if that fails a list !! of variable names assumed to contain directory paths {PATH|HOME} are !! examined first for a backslash, then a slash. Assuming basically the !! choice is a ULS or MSWindows system, and users can do weird things like !! put a backslash in a ULS path and break it. !! !! Therefore can be very system dependent. If the queries fail the !! default returned is \"/\". !! !!##EXAMPLE !! !! sample usage !! !! program demo_separator !! use M_io, only : separator !! implicit none !! write(*,*)'separator=',separator() !! end program demo_separator ! use the pathname returned as arg0 to determine pathname separator integer :: ios integer :: i logical :: existing = . false . character ( len = 1 ) :: sep !x!IFORT BUG:character(len=1),save :: sep_cache=' ' integer , save :: isep =- 1 character ( len = 4096 ) :: name character ( len = :), allocatable :: envnames (:) ! NOTE: A parallel code might theoretically use multiple OS !x!FORT BUG:if(sep_cache /= ' ')then ! use cached value. !x!FORT BUG: sep=sep_cache !x!FORT BUG: return !x!FORT BUG:endif if ( isep /= - 1 ) then ! use cached value. sep = char ( isep ) return endif FOUND : block ! simple, but does not work with ifort ! most MSWindows environments see to work with backslash even when ! using POSIX filenames to do not rely on '\\.'. inquire ( file = '/.' , exist = existing , iostat = ios , name = name ) if ( existing . and . ios == 0 ) then sep = '/' exit FOUND endif ! check variables names common to many platforms that usually have a ! directory path in them although a ULS file can contain a backslash ! and vice-versa (eg. \"touch A\\\\B\\\\C\"). Removed HOMEPATH because it ! returned a name with backslash on CygWin, Mingw, WLS even when using ! POSIX filenames in the environment. envnames = [ character ( len = 10 ) :: 'PATH' , 'HOME' ] do i = 1 , size ( envnames ) if ( index ( get_env ( envnames ( i )), '\\') /= 0)then sep=' \\ ' exit FOUND elseif(index(get_env(envnames(i)),' / ') /= 0)then sep=' / ' exit FOUND endif enddo write(*,*)' < WARNING > unknown system directory path separator ' sep=' \\ ' endblock FOUND !x!IFORT BUG:sep_cache=sep isep=ichar(sep) end function separator !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine cmd_args_to_dictionary() ! convert command line arguments to dictionary entries !x!logical :: guess_if_value integer :: pointer character(len=:),allocatable :: lastkeyword integer :: i, jj, kk integer :: ilength, istatus, imax character(len=1) :: letter character(len=:),allocatable :: current_argument character(len=:),allocatable :: current_argument_padded character(len=:),allocatable :: dummy character(len=:),allocatable :: oldvalue logical :: nomore logical :: next_mandatory if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : START ' next_mandatory=.false. nomore=.false. pointer=0 lastkeyword=' ' G_keyword_single_letter=.true. i=1 current_argument='' GET_ARGS: do while (get_next_argument()) ! insert and replace entries if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : WHILE : CURRENT_ARGUMENT = ',current_argument if( current_argument == ' - ' .and. nomore .eqv. .true. )then ! sort of elseif( current_argument == ' - ')then ! sort of current_argument=' \"stdin\" ' endif if( current_argument == ' -- ' .and. nomore .eqv. .true. )then ! -- was already encountered elseif( current_argument == ' -- ' )then ! everything after this goes into the unnamed array nomore=.true. pointer=0 if(G_remaining_option_allowed)then G_remaining_on=.true. endif cycle GET_ARGS endif dummy=current_argument//' ' current_argument_padded=current_argument//' ' if(.not.next_mandatory.and..not.nomore.and.current_argument_padded(1:2) == ' -- ')then ! beginning of long word if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : START_LONG : ' G_keyword_single_letter=.false. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(3:),pointer) if(pointer <= 0)then if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call print_dictionary(' UNKNOWN LONG KEYWORD : '//current_argument) call mystop(1) return endif lastkeyword=trim(current_argument_padded(3:)) next_mandatory=mandatory(pointer) elseif(.not.next_mandatory & & .and..not.nomore & & .and.current_argument_padded(1:1) == ' - ' & & .and.index(\"0123456789.\",dummy(2:2)) == 0)then ! short word if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : START_SHORT ' G_keyword_single_letter=.true. if(lastkeyword /= '')then call ifnull() endif call locate_key(current_argument_padded(2:),pointer) jj=len(current_argument) if( (pointer <= 0.or.jj.ge.3).and.(G_STRICT) )then ! name not found if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : SHORT NOT FOUND : ',current_argument_padded(2:) ! in strict mode this might be multiple single-character values do kk=2,jj letter=current_argument_padded(kk:kk) call locate_key(letter,pointer) if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : LETTER : ',letter,pointer if(pointer > 0)then call update(keywords(pointer),' T ') else if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : UNKNOWN SHORT : ',letter call print_dictionary(' UNKNOWN SHORT KEYWORD : '//letter) ! //' in '//current_argument) if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call mystop(2) return endif current_argument=' - '//current_argument_padded(jj:jj) enddo !-------------- lastkeyword=\"\" pointer=0 if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : SHORT_END : 2 : ' cycle GET_ARGS !-------------- elseif(pointer<0)then if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : UNKNOWN SHORT_CONFIRMED : ',letter call print_dictionary(' UNKNOWN SHORT KEYWORD : '//current_argument_padded(2:)) if(G_QUIET)then lastkeyword=\"UNKNOWN\" pointer=0 cycle GET_ARGS endif call mystop(2) return endif if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : SHORT_END : 1 : ' lastkeyword=trim(current_argument_padded(2:)) next_mandatory=mandatory(pointer) elseif(pointer == 0)then ! unnamed arguments if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : UNNAMED ARGUMENT : ',current_argument if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//' \"\" ' elseif(current_argument(1:1) == ' - ')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//' \"'//current_argument//'\" ' else G_remaining=G_remaining//' \"'//current_argument//'\" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ',' @ ') == 1.and.G_response)then if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : 1 : CALL EXPAND_RESPONSE : CURRENT_ARGUMENT = ',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif else if(G_DEBUG)write(*,gen)' < DEBUG > CMD_ARGS_TO_DICTIONARY : FOUND : ',current_argument oldvalue=get(keywords(pointer))//' ' if(oldvalue(1:1) == ' \"')then current_argument=quote(current_argument(:ilength)) endif if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then ! assume boolean parameter if(current_argument /= ' ')then if(G_remaining_on)then if(len(current_argument) < 1)then G_remaining=G_remaining//'\"\" ' elseif(current_argument(1:1) == '-')then !get fancier to handle spaces and =!G_remaining=G_remaining//current_argument//' ' G_remaining=G_remaining//'\" '//current_argument//' \" ' else G_remaining=G_remaining//'\" '//current_argument//' \" ' endif imax=max(len(args),len(current_argument)) args=[character(len=imax) :: args,current_argument] else imax=max(len(unnamed),len(current_argument)) if(scan(current_argument//' ','@') == 1.and.G_response)then if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:2:CALL EXPAND_RESPONSE:CURRENT_ARGUMENT=',current_argument call expand_response(current_argument) else unnamed=[character(len=imax) :: unnamed,current_argument] endif endif endif current_argument='T' endif call update(keywords(pointer),current_argument) pointer=0 lastkeyword='' next_mandatory=.false. endif enddo GET_ARGS if(lastkeyword /= '')then call ifnull() endif if(G_DEBUG)write(*,gen)'CMD_ARGS_TO_DICTIONARY:NORMAL END' contains subroutine ifnull() oldvalue=get(lastkeyword)//' ' if(upper(oldvalue) == 'F'.or.upper(oldvalue) == 'T')then call update(lastkeyword,'T') elseif(oldvalue(1:1) == '\" ')then call update(lastkeyword,' \" \" ') else call update(lastkeyword,' ') endif end subroutine ifnull function get_next_argument() ! ! get next argument from command line into allocated variable current_argument ! logical,save :: hadequal=.false. character(len=:),allocatable,save :: right_hand_side logical :: get_next_argument integer :: iright integer :: iequal if(hadequal)then ! use left-over value from previous -NAME=VALUE syntax current_argument=right_hand_side right_hand_side='' hadequal=.false. get_next_argument=.true. ilength=len(current_argument) return endif if(i>command_argument_count())then get_next_argument=.false. return else get_next_argument=.true. endif call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)' * prototype_and_cmd_args_to_nlist * error obtaining argument ',i,& &' status = ',istatus,& &' length = ',ilength get_next_argument=.false. else ilength=max(ilength,1) if(allocated(current_argument))deallocate(current_argument) allocate(character(len=ilength) :: current_argument) call get_command_argument(number=i,value=current_argument,length=ilength,status=istatus) ! get next argument if(istatus /= 0) then ! on error write(warn,*)' * prototype_and_cmd_args_to_nlist * error obtaining argument ',i,& &' status = ',istatus,& &' length = ',ilength,& &' target length = ',len(current_argument) get_next_argument=.false. endif ! if an argument keyword and an equal before a space split on equal and save right hand side for next call if(nomore)then elseif( len(current_argument) == 0)then else iright=index(current_argument,' ') if(iright == 0)iright=len(current_argument) iequal=index(current_argument(:iright),' = ') if(next_mandatory)then elseif(iequal /= 0.and.current_argument(1:1) == ' - ')then if(iequal /= len(current_argument))then right_hand_side=current_argument(iequal+1:) else right_hand_side='' endif hadequal=.true. current_argument=current_argument(:iequal-1) endif endif endif i=i+1 end function get_next_argument end subroutine cmd_args_to_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary !! created by calls to set_args(3f) !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine print_dictionary(header,stop) !! !! character(len=*),intent(in),optional :: header !! logical,intent(in),optional :: stop !!##DESCRIPTION !! Print the internal dictionary created by calls to set_args(3f). !! This routine is intended to print the state of the argument list !! if an error occurs in using the set_args(3f) procedure. !!##OPTIONS !! HEADER label to print before printing the state of the command !! argument list. !! STOP logical value that if true stops the program after displaying !! the dictionary. !!##EXAMPLE !! !! !! !! Typical usage: !! !! program demo_print_dictionary !! use M_CLI2, only : set_args, get_args !! implicit none !! real :: x, y, z !! call set_args(' - x 10 - y 20 - z 30 ') !! call get_args(' x ',x,' y ',y,' z ',z) !! ! all done cracking the command line; use the values in your program. !! write(*,*)x,y,z !! end program demo_print_dictionary !! !! Sample output !! !! Calling the sample program with an unknown parameter or the --usage !! switch produces the following: !! !! $ ./demo_print_dictionary -A !! UNKNOWN SHORT KEYWORD: -A !! KEYWORD PRESENT VALUE !! z F [3] !! y F [2] !! x F [1] !! help F [F] !! version F [F] !! usage F [F] !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine print_dictionary(header,stop) character(len=*),intent(in),optional :: header logical,intent(in),optional :: stop integer :: i if(G_QUIET)return if(present(header))then if(header /= '')then write(warn,' ( a ) ')header endif endif if(allocated(keywords))then if(size(keywords) > 0)then write(warn,' ( a , 1 x , a , 1 x , a , 1 x , a ) ')atleast(' KEYWORD ',max(len(keywords),8)),' SHORT ',' PRESENT ',' VALUE ' write(warn,' ( * ( a , 1 x , a5 , 1 x , l1 , 8 x , \"[\" , a , \"]\" , / )) ') & & (atleast(keywords(i),max(len(keywords),8)),shorts(i),present_in(i),values(i)(:counts(i)),i=size(keywords),1,-1) endif endif if(allocated(unnamed))then if(size(unnamed) > 0)then write(warn,' ( a ) ')' UNNAMED ' write(warn,' ( i6 . 6 , 3 a ) ')(i,' [ ',unnamed(i),' ] ',i=1,size(unnamed)) endif endif if(allocated(args))then if(size(args) > 0)then write(warn,' ( a ) ')' ARGS ' write(warn,' ( i6 . 6 , 3 a ) ')(i,' [ ',args(i),' ] ',i=1,size(args)) endif endif if(G_remaining /= '')then write(warn,' ( a ) ')' REMAINING ' write(warn,' ( a ) ')G_remaining endif if(present(stop))then if(stop) call mystop(5) endif end subroutine print_dictionary !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing !! command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! get_args(3f) and its convenience functions: !! !! use M_CLI2, only : get_args !! ! convenience functions !! use M_CLI2, only : dget, iget, lget, rget, sget, cget !! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets !! !! subroutine get_args(name,value,delimiters) !! !! character(len=*),intent(in) :: name !! !! type(${TYPE}),allocatable,intent(out) :: value(:) !! ! or !! type(${TYPE}),allocatable,intent(out) :: value !! !! character(len=*),intent(in),optional :: delimiters !! !! where ${TYPE} may be from the set !! {real,doubleprecision,integer,logical,complex,character(len=:)} !!##DESCRIPTION !! !! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has !! been called to parse the command line. For fixed-length CHARACTER !! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see !! GET_ARGS_FIXED_SIZE(3f). !! !! As a convenience multiple pairs of keywords and variables may be !! specified if and only if all the values are scalars and the CHARACTER !! variables are fixed-length or pre-allocated. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! VALUE variable to hold returned value. The kind of the value !! is used to determine the type of returned value. May !! be a scalar or allocatable array. If type is CHARACTER !! the scalar must have an allocatable length. !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##CONVENIENCE FUNCTIONS !! There are convenience functions that are replacements for calls to !! get_args(3f) for each supported default intrinsic type !! !! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), !! cget(3f) !! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), !! sgets(3f), cgets(3f) !! !! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, !! S for string (CHARACTER), and C for COMPLEX. !! !! If the functions are called with no argument they will return the !! UNNAMED array converted to the specified type. !! !!##EXAMPLE !! !! !! Sample program: !! !! program demo_get_args !! use M_CLI2, only : filenames=>unnamed, set_args, get_args !! implicit none !! integer :: i !! ! Define ARGS !! real :: x, y, z !! real,allocatable :: p(:) !! character(len=:),allocatable :: title !! logical :: l, lbig !! ! Define and parse (to set initial values) command line !! ! o only quote strings and use double-quotes !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 1 -y 2 -z 3 & !! & -p -1,-2,-3 & !! & --title \"my title\" & !! & -l F -L F & !! & --label \" \" & !! & ') !! ! Assign values to elements !! ! Scalars !! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig) !! ! Allocatable string !! call get_args('title',title) !! ! Allocatable arrays !! call get_args('p',p) !! ! Use values !! write(*,'(1x,g0,\"=\",g0)')'x',x, 'y',y, 'z',z !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! if(size(filenames) > 0)then !! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) !! endif !! end program demo_get_args !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-length string when parsing command line !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_length(name,value) !! !! character(len=*),intent(in) :: name !! character(len=:),allocatable :: value !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_length(3f) returns the value of a string !! keyword when the string value is a fixed-length CHARACTER !! variable. !! !!##OPTIONS !! !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned value. !! Must be a fixed-length CHARACTER variable. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_length !! use M_CLI2, only : set_args, get_args_fixed_length !! implicit none !! !! ! Define args !! character(len=80) :: title !! ! Parse command line !! call set_args(' --title \"my title\" ') !! ! Assign values to variables !! call get_args_fixed_length('title',title) !! ! Use values !! write(*,*)'title=',title !! !! end program demo_get_args_fixed_length !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== !> !!##NAME !! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values !! for fixed-size array when parsing command line arguments !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine get_args_fixed_size(name,value) !! !! character(len=*),intent(in) :: name !! [real|doubleprecision|integer|logical|complex] :: value(NNN) !! or !! character(len=MMM) :: value(NNN) !! !! character(len=*),intent(in),optional :: delimiters !! !!##DESCRIPTION !! !! get_args_fixed_size(3f) returns the value of keywords for fixed-size !! arrays after set_args(3f) has been called. On input on the command !! line all values of the array must be specified. !! !!##OPTIONS !! NAME name of commandline argument to obtain the value of !! !! VALUE variable to hold returned values. The kind of the value !! is used to determine the type of returned value. Must be !! a fixed-size array. If type is CHARACTER the length must !! also be fixed. !! !! DELIMITERS By default the delimiter for array values are comma, !! colon, and whitespace. A string containing an alternate !! list of delimiter characters may be supplied. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_get_args_fixed_size !! use M_CLI2, only : set_args, get_args_fixed_size !! implicit none !! integer,parameter :: dp=kind(0.0d0) !! ! DEFINE ARGS !! real :: x(2) !! real(kind=dp) :: y(2) !! integer :: p(3) !! character(len=80) :: title(1) !! logical :: l(4), lbig(4) !! complex :: cmp(2) !! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE !! ! o only quote strings !! ! o set all logical values to F or T. !! call set_args(' & !! & -x 10.0,20.0 & !! & -y 11.0,22.0 & !! & -p -1,-2,-3 & !! & --title \"my title\" & !! & -l F,T,F,T -L T,F,T,F & !! & --cmp 111,222.0,333.0e0,4444 & !! & ') !! ! ASSIGN VALUES TO ELEMENTS !! call get_args_fixed_size('x',x) !! call get_args_fixed_size('y',y) !! call get_args_fixed_size('p',p) !! call get_args_fixed_size('title',title) !! call get_args_fixed_size('l',l) !! call get_args_fixed_size('L',lbig) !! call get_args_fixed_size('cmp',cmp) !! ! USE VALUES !! write(*,*)'x=',x !! write(*,*)'p=',p !! write(*,*)'title=',title !! write(*,*)'l=',l !! write(*,*)'L=',lbig !! write(*,*)'cmp=',cmp !! end program demo_get_args_fixed_size !! Results: !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== subroutine get_fixedarray_class ( keyword , generic , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary class ( * ) :: generic (:) character ( len =* ), intent ( in ), optional :: delimiters select type ( generic ) type is ( character ( len =* )); call get_fixedarray_fixed_length_c ( keyword , generic , delimiters ) type is ( integer ); call get_fixedarray_i ( keyword , generic , delimiters ) type is ( real ); call get_fixedarray_r ( keyword , generic , delimiters ) type is ( complex ); call get_fixed_size_complex ( keyword , generic , delimiters ) type is ( real ( kind = dp )); call get_fixedarray_d ( keyword , generic , delimiters ) type is ( logical ); call get_fixedarray_l ( keyword , generic , delimiters ) class default call mystop ( - 7 , '*get_fixedarray_class* crud -- procedure does not know about this type' ) end select end subroutine get_fixedarray_class !=================================================================================================================================== ! return allocatable arrays !=================================================================================================================================== subroutine get_anyarray_l ( keyword , larray , delimiters ) ! ident_5=\"@(#) M_CLI2 get_anyarray_l(3f) given keyword fetch logical array from string in dictionary(F on err)\" character ( len =* ), intent ( in ) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve logical , allocatable :: larray (:) ! convert value to an array character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: carray (:) ! convert value to an array character ( len = :), allocatable :: val integer :: i integer :: place integer :: iichar ! point to first character of word unless first character is \".\" call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if string was found val = values ( place )(: counts ( place )) call split ( adjustl ( upper ( val )), carray , delimiters = delimiters ) ! convert value to uppercase, trimmed; then parse into array else call journal ( '*get_anyarray_l* unknown keyword' , keyword ) call mystop ( 8 , '*get_anyarray_l* unknown keyword ' // keyword ) if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( 0 )) return endif if ( size ( carray ) > 0 ) then ! if not a null string if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( size ( carray ))) ! allocate output array do i = 1 , size ( carray ) larray ( i ) = . false . ! initialize return value to .false. if ( carray ( i )( 1 : 1 ) == '.' ) then ! looking for fortran logical syntax .STRING. iichar = 2 else iichar = 1 endif select case ( carray ( i )( iichar : iichar )) ! check word to see if true or false case ( 'T' , 'Y' , ' ' ); larray ( i ) = . true . ! anything starting with \"T\" or \"Y\" or a blank is TRUE (true,yes,...) case ( 'F' , 'N' ); larray ( i ) = . false . ! assume this is false or no case default call journal ( \"*get_anyarray_l* bad logical expression for \" ,( keyword ), '=' , carray ( i )) end select enddo else ! for a blank string return one T if ( allocated ( larray )) deallocate ( larray ) allocate ( larray ( 1 )) ! allocate output array larray ( 1 ) = . true . endif end subroutine get_anyarray_l !=================================================================================================================================== subroutine get_anyarray_d ( keyword , darray , delimiters ) ! ident_6=\"@(#) M_CLI2 get_anyarray_d(3f) given keyword fetch dble value array from Language Dictionary (0 on err)\" character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ), allocatable , intent ( out ) :: darray (:) ! function type character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: carray (:) ! convert value to an array using split(3f) integer :: i integer :: place integer :: ierr character ( len = :), allocatable :: val !----------------------------------------------------------------------------------------------------------------------------------- call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if string was found val = values ( place )(: counts ( place )) val = replace_str ( val , '(' , '' ) val = replace_str ( val , ')' , '' ) call split ( val , carray , delimiters = delimiters ) ! find value associated with keyword and split it into an array else call journal ( '*get_anyarray_d* unknown keyword ' // keyword ) call mystop ( 9 , '*get_anyarray_d* unknown keyword ' // keyword ) if ( allocated ( darray )) deallocate ( darray ) allocate ( darray ( 0 )) return endif if ( allocated ( darray )) deallocate ( darray ) allocate ( darray ( size ( carray ))) ! create the output array do i = 1 , size ( carray ) call a2d ( carray ( i ), darray ( i ), ierr ) ! convert the string to a numeric value if ( ierr /= 0 ) then call mystop ( 10 , '*get_anyarray_d* unreadable value ' // carray ( i ) // ' for keyword ' // keyword ) endif enddo end subroutine get_anyarray_d !=================================================================================================================================== subroutine get_anyarray_i ( keyword , iarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer , allocatable :: iarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type call get_anyarray_d ( keyword , darray , delimiters ) iarray = nint ( darray ) end subroutine get_anyarray_i !=================================================================================================================================== subroutine get_anyarray_r ( keyword , rarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real , allocatable :: rarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type call get_anyarray_d ( keyword , darray , delimiters ) rarray = real ( darray ) end subroutine get_anyarray_r !=================================================================================================================================== subroutine get_anyarray_x ( keyword , xarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex ( kind = sp ), allocatable :: xarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: half , sz , i call get_anyarray_d ( keyword , darray , delimiters ) sz = size ( darray ) half = sz / 2 if ( sz /= half + half ) then call journal ( '*get_anyarray_x* uneven number of values defining complex value ' // keyword ) call mystop ( 11 , '*get_anyarray_x* uneven number of values defining complex value ' // keyword ) if ( allocated ( xarray )) deallocate ( xarray ) allocate ( xarray ( 0 )) endif !x!================================================================================================ !x!IFORT,GFORTRAN OK, NVIDIA RETURNS NULL ARRAY: xarray=cmplx(real(darray(1::2)),real(darray(2::2))) if ( allocated ( xarray )) deallocate ( xarray ) allocate ( xarray ( half )) do i = 1 , sz , 2 xarray (( i + 1 ) / 2 ) = cmplx ( darray ( i ), darray ( i + 1 ), kind = sp ) enddo !x!================================================================================================ end subroutine get_anyarray_x !=================================================================================================================================== subroutine get_anyarray_c ( keyword , strings , delimiters ) ! ident_8=\"@(#)M_CLI2::get_anyarray_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len = :), allocatable :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters integer :: place character ( len = :), allocatable :: val call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , strings , delimiters = delimiters ) ! find value associated with keyword and split it into an array else call journal ( '*get_anyarray_c* unknown keyword ' // keyword ) call mystop ( 12 , '*get_anyarray_c* unknown keyword ' // keyword ) if ( allocated ( strings )) deallocate ( strings ) allocate ( character ( len = 0 ) :: strings ( 0 )) endif end subroutine get_anyarray_c !=================================================================================================================================== !=================================================================================================================================== subroutine get_args_fixed_length_a_array ( keyword , strings , delimiters ) ! ident_7=\"@(#) M_CLI2 get_args_fixed_length_a_array(3f) Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len =* ), allocatable :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: strings_a (:) integer :: place character ( len = :), allocatable :: val integer :: ibug call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , strings_a , delimiters = delimiters ) ! find value associated with keyword and split it into an array if ( len ( strings_a ) <= len ( strings ) ) then strings = strings_a else ibug = len ( strings ) call journal ( '*get_args_fixed_length_a_array* values too long. Longest is' , len ( strings_a ), 'allowed is' , ibug ) write ( * , '(\"strings=\",3x,*(a,1x))' ) strings call journal ( '*get_args_fixed_length_a_array* keyword=' // keyword ) call mystop ( 13 , '*get_args_fixed_length_a_array* keyword=' // keyword ) strings = [ character ( len = len ( strings )) :: ] endif else call journal ( '*get_args_fixed_length_a_array* unknown keyword ' // keyword ) call mystop ( 14 , '*get_args_fixed_length_a_array* unknown keyword ' // keyword ) strings = [ character ( len = len ( strings )) :: ] endif end subroutine get_args_fixed_length_a_array !=================================================================================================================================== ! return non-allocatable arrays !=================================================================================================================================== subroutine get_fixedarray_i ( keyword , iarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer :: iarray (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_d ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( iarray , dim = 1 ) == dsize ) then iarray = nint ( darray ) else ibug = size ( iarray ) call journal ( '*get_fixedarray_i* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 33 ) iarray = 0 endif end subroutine get_fixedarray_i !=================================================================================================================================== subroutine get_fixedarray_r ( keyword , rarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real :: rarray (:) character ( len =* ), intent ( in ), optional :: delimiters real , allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_r ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( rarray , dim = 1 ) == dsize ) then rarray = darray else ibug = size ( rarray ) call journal ( '*get_fixedarray_r* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 33 ) rarray = 0.0 endif end subroutine get_fixedarray_r !=================================================================================================================================== subroutine get_fixed_size_complex ( keyword , xarray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex :: xarray (:) character ( len =* ), intent ( in ), optional :: delimiters complex , allocatable :: darray (:) ! function type integer :: half , sz integer :: dsize integer :: ibug call get_anyarray_x ( keyword , darray , delimiters ) dsize = size ( darray ) sz = dsize * 2 half = sz / 2 if ( sz /= half + half ) then call journal ( '*get_fixed_size_complex* uneven number of values defining complex value ' // keyword ) call mystop ( 15 , '*get_fixed_size_complex* uneven number of values defining complex value ' // keyword ) xarray = 0 return endif if ( ubound ( xarray , dim = 1 ) == dsize ) then xarray = darray else ibug = size ( xarray ) call journal ( '*get_fixed_size_complex* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 34 ) xarray = cmplx ( 0.0 , 0.0 ) endif end subroutine get_fixed_size_complex !=================================================================================================================================== subroutine get_fixedarray_d ( keyword , darr , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ) :: darr (:) character ( len =* ), intent ( in ), optional :: delimiters real ( kind = dp ), allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_d ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( darr , dim = 1 ) == dsize ) then darr = darray else ibug = size ( darr ) call journal ( '*get_fixedarray_d* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 35 ) darr = 0.0d0 endif end subroutine get_fixedarray_d !=================================================================================================================================== subroutine get_fixedarray_l ( keyword , larray , delimiters ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary logical :: larray (:) character ( len =* ), intent ( in ), optional :: delimiters logical , allocatable :: darray (:) ! function type integer :: dsize integer :: ibug call get_anyarray_l ( keyword , darray , delimiters ) dsize = size ( darray ) if ( ubound ( larray , dim = 1 ) == dsize ) then larray = darray else ibug = size ( larray ) call journal ( '*get_fixedarray_l* wrong number of values for keyword' , keyword , 'got' , dsize , 'expected' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 36 ) larray = . false . endif end subroutine get_fixedarray_l !=================================================================================================================================== subroutine get_fixedarray_fixed_length_c ( keyword , strings , delimiters ) ! ident_8=\"@(#) M_CLI2 get_fixedarray_fixed_length_c(3f) Fetch strings value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ) :: strings (:) character ( len =* ), intent ( in ), optional :: delimiters character ( len = :), allocatable :: str (:) character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary integer :: place integer :: ssize integer :: ibug character ( len = :), allocatable :: val call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return strings val = unquote ( values ( place )(: counts ( place ))) call split ( val , str , delimiters = delimiters ) ! find value associated with keyword and split it into an array ssize = size ( str ) if ( ssize == size ( strings )) then strings (: ssize ) = str else ibug = size ( strings ) call journal ( '*get_fixedarray_fixed_length_c* wrong number of values for keyword' ,& & keyword , 'got' , ssize , 'expected ' , ibug ) !,ubound(strings,dim=1) call print_dictionary ( 'USAGE:' ) call mystop ( 30 , '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) strings = '' endif else call journal ( '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) call mystop ( 16 , '*get_fixedarray_fixed_length_c* unknown keyword ' // keyword ) strings = '' endif end subroutine get_fixedarray_fixed_length_c !=================================================================================================================================== ! return scalars !=================================================================================================================================== subroutine get_scalar_d ( keyword , d ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real ( kind = dp ) :: d real ( kind = dp ), allocatable :: darray (:) ! function type integer :: ibug call get_anyarray_d ( keyword , darray ) if ( size ( darray ) == 1 ) then d = darray ( 1 ) else ibug = size ( darray ) call journal ( '*get_anyarray_d* incorrect number of values for keyword \"' , keyword , '\" expected one found' , ibug ) call print_dictionary ( 'USAGE:' ) call mystop ( 31 , '*get_anyarray_d* incorrect number of values for keyword \"' // keyword // '\" expected one' ) endif end subroutine get_scalar_d !=================================================================================================================================== subroutine get_scalar_real ( keyword , r ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary real , intent ( out ) :: r real ( kind = dp ) :: d call get_scalar_d ( keyword , d ) r = real ( d ) end subroutine get_scalar_real !=================================================================================================================================== subroutine get_scalar_i ( keyword , i ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary integer , intent ( out ) :: i real ( kind = dp ) :: d call get_scalar_d ( keyword , d ) i = nint ( d ) end subroutine get_scalar_i !=================================================================================================================================== subroutine get_scalar_anylength_c ( keyword , string ) ! ident_9=\"@(#) M_CLI2 get_scalar_anylength_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len = :), allocatable , intent ( out ) :: string integer :: place call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return string string = unquote ( values ( place )(: counts ( place ))) else call mystop ( 17 , '*get_anyarray_c* unknown keyword ' // keyword ) call journal ( '*get_anyarray_c* unknown keyword ' // keyword ) string = '' endif end subroutine get_scalar_anylength_c !=================================================================================================================================== elemental impure subroutine get_args_fixed_length_scalar_c ( keyword , string ) ! ident_10=\"@(#) M_CLI2 get_args_fixed_length_scalar_c(3f) Fetch string value for specified KEYWORD from the lang. dictionary\" ! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary character ( len =* ), intent ( in ) :: keyword ! name to look up in dictionary character ( len =* ), intent ( out ) :: string integer :: place integer :: unlen integer :: ibug call locate_key ( keyword , place ) ! find where string is or should be if ( place > 0 ) then ! if index is valid return string string = unquote ( values ( place )(: counts ( place ))) else call mystop ( 18 , '*get_args_fixed_length_scalar_c* unknown keyword ' // keyword ) string = '' endif unlen = len_trim ( unquote ( values ( place )(: counts ( place )))) if ( unlen > len ( string )) then ibug = len ( string ) call journal ( '*get_args_fixed_length_scalar_c* value too long for' , keyword , 'allowed is' , ibug ,& & 'input string [' , values ( place ), '] is' , unlen ) call mystop ( 19 , '*get_args_fixed_length_scalar_c* value too long' ) string = '' endif end subroutine get_args_fixed_length_scalar_c !=================================================================================================================================== subroutine get_scalar_complex ( keyword , x ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary complex , intent ( out ) :: x real ( kind = dp ) :: d ( 2 ) call get_fixedarray_d ( keyword , d ) x = cmplx ( d ( 1 ), d ( 2 ), kind = sp ) end subroutine get_scalar_complex !=================================================================================================================================== subroutine get_scalar_logical ( keyword , l ) character ( len =* ), intent ( in ) :: keyword ! keyword to retrieve value from dictionary logical :: l logical , allocatable :: larray (:) ! function type integer :: ibug l = . false . call get_anyarray_l ( keyword , larray ) if (. not . allocated ( larray ) ) then call journal ( '*get_scalar_logical* expected one value found not allocated' ) call mystop ( 37 , '*get_scalar_logical* incorrect number of values for keyword \"' // keyword // '\"' ) elseif ( size ( larray ) == 1 ) then l = larray ( 1 ) else ibug = size ( larray ) call journal ( '*get_scalar_logical* expected one value found' , ibug ) call mystop ( 21 , '*get_scalar_logical* incorrect number of values for keyword \"' // keyword // '\"' ) endif end subroutine get_scalar_logical !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== ! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE !use M_list, only : insert, locate, remove, replace !use M_journal, only : JOURNAL !use M_args, only : LONGEST_COMMAND_ARGUMENT ! routines extracted from other modules !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest !! argument on command line !! (LICENSE:PD) !!##SYNOPSIS !! !! function longest_command_argument() result(ilongest) !! !! integer :: ilongest !! !!##DESCRIPTION !! length of longest argument on command line. Useful when allocating !! storage for holding arguments. !!##RESULT !! longest_command_argument length of longest command argument !!##EXAMPLE !! !! Sample program !! !! program demo_longest_command_argument !! use M_args, only : longest_command_argument !! write(*,*)'longest argument is ',longest_command_argument() !! end program demo_longest_command_argument !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain function longest_command_argument () result ( ilongest ) integer :: i integer :: ilength integer :: istatus integer :: ilongest ilength = 0 ilongest = 0 GET_LONGEST : do i = 1 , command_argument_count () ! loop throughout command line arguments to find longest call get_command_argument ( number = i , length = ilength , status = istatus ) ! get next argument if ( istatus /= 0 ) then ! on error write ( warn , * ) '*prototype_and_cmd_args_to_nlist* error obtaining length for argument ' , i exit GET_LONGEST elseif ( ilength > 0 ) then ilongest = max ( ilongest , ilength ) endif enddo GET_LONGEST end function longest_command_argument !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! journal(3f) - [M_CLI2] converts a list of standard scalar types to a string and writes message !! (LICENSE:PD) !!##SYNOPSIS !! !! subroutine journal(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep) !! !! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 !! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj !! character(len=*),intent(in),optional :: sep !! !!##DESCRIPTION !! journal(3f) builds and prints a space-separated string from up to twenty scalar values. !! !!##OPTIONS !! g[0-9a-j] optional value to print the value of after the message. May !! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, !! COMPLEX, or CHARACTER. !! !! sep separator to place between values. Defaults to a space. !!##RETURNS !! journal description to print !!##EXAMPLES !! !! Sample program: !! !! program demo_journal !! use M_CLI2, only : journal !! implicit none !! character(len=:),allocatable :: frmt !! integer :: biggest !! !! call journal('HUGE(3f) integers',huge(0),'and real',& !! & huge(0.0),'and double',huge(0.0d0)) !! call journal('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) !! call journal('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) !! call journal('complex :',cmplx(huge(0.0),tiny(0.0)) ) !! !! end program demo_journal !! !! Output !! !! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and !! double 1.7976931348623157E+308 !! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 !! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 !! 12345.678900000001 2.2250738585072014E-308 !! complex : (3.40282347E+38,1.17549435E-38) !! format=(*(i9:,1x)) !! program will now stop !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine journal ( g0 , g1 , g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 , ga , gb , gc , gd , ge , gf , gg , gh , gi , gj , sep ) ! ident_11=\"@(#) M_CLI2 journal(3fp) writes a message to a string composed of any standard scalar types\" class ( * ), intent ( in ), optional :: g0 , g1 , g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 , ga , gb , gc , gd , ge , gf , gg , gh , gi , gj character ( len =* ), intent ( in ), optional :: sep character ( len = :), allocatable :: sep_local character ( len = 4096 ) :: line integer :: istart integer :: increment if ( present ( sep )) then sep_local = sep increment = len ( sep_local ) + 1 else sep_local = ' ' increment = 2 endif istart = 1 line = '' if ( present ( g0 )) call print_generic ( g0 ) if ( present ( g1 )) call print_generic ( g1 ) if ( present ( g2 )) call print_generic ( g2 ) if ( present ( g3 )) call print_generic ( g3 ) if ( present ( g4 )) call print_generic ( g4 ) if ( present ( g5 )) call print_generic ( g5 ) if ( present ( g6 )) call print_generic ( g6 ) if ( present ( g7 )) call print_generic ( g7 ) if ( present ( g8 )) call print_generic ( g8 ) if ( present ( g9 )) call print_generic ( g9 ) if ( present ( ga )) call print_generic ( ga ) if ( present ( gb )) call print_generic ( gb ) if ( present ( gc )) call print_generic ( gc ) if ( present ( gd )) call print_generic ( gd ) if ( present ( ge )) call print_generic ( ge ) if ( present ( gf )) call print_generic ( gf ) if ( present ( gg )) call print_generic ( gg ) if ( present ( gh )) call print_generic ( gh ) if ( present ( gi )) call print_generic ( gi ) if ( present ( gj )) call print_generic ( gj ) write ( * , '(a)' ) trim ( line ) contains !=================================================================================================================================== subroutine print_generic ( generic ) use , intrinsic :: iso_fortran_env , only : int8 , int16 , int32 , int64 , real32 , real64 , real128 class ( * ), intent ( in ) :: generic select type ( generic ) type is ( integer ( kind = int8 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int16 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int32 )); write ( line ( istart :), '(i0)' ) generic type is ( integer ( kind = int64 )); write ( line ( istart :), '(i0)' ) generic type is ( real ( kind = real32 )); write ( line ( istart :), '(1pg0)' ) generic type is ( real ( kind = real64 )) write ( line ( istart :), '(1pg0)' ) generic !x! DOES NOT WORK WITH NVFORTRAN: type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic type is ( logical ) write ( line ( istart :), '(l1)' ) generic type is ( character ( len =* )) write ( line ( istart :), '(a)' ) trim ( generic ) type is ( complex ); write ( line ( istart :), '(\"(\",1pg0,\",\",1pg0,\")\")' ) generic end select istart = len_trim ( line ) + increment line = trim ( line ) // sep_local end subroutine print_generic !=================================================================================================================================== end subroutine journal !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function upper ( str ) result ( string ) ! ident_12=\"@(#) M_CLI2 upper(3f) Changes a string to uppercase\" character ( * ), intent ( in ) :: str character (:), allocatable :: string integer :: i string = str do i = 1 , len_trim ( str ) select case ( str ( i : i )) case ( 'a' : 'z' ) string ( i : i ) = char ( iachar ( str ( i : i )) - 32 ) end select end do end function upper !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function lower ( str ) result ( string ) ! ident_13=\"@(#) M_CLI2 lower(3f) Changes a string to lowercase over specified range\" character ( * ), intent ( In ) :: str character (:), allocatable :: string integer :: i string = str do i = 1 , len_trim ( str ) select case ( str ( i : i )) case ( 'A' : 'Z' ) string ( i : i ) = char ( iachar ( str ( i : i )) + 32 ) end select end do end function lower !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== subroutine a2i ( chars , valu , ierr ) ! ident_14=\"@(#) M_CLI2 a2i(3fp) subroutine returns integer value from string\" character ( len =* ), intent ( in ) :: chars ! input string integer , intent ( out ) :: valu ! value read from input string integer , intent ( out ) :: ierr ! error flag (0 == no error) doubleprecision :: valu8 integer , parameter :: ihuge = huge ( 0 ) valu8 = 0.0d0 call a2d ( chars , valu8 , ierr , onerr = 0.0d0 ) if ( valu8 <= huge ( valu )) then if ( valu8 <= huge ( valu )) then valu = int ( valu8 ) else call journal ( '*a2i*' , '- value too large' , valu8 , '>' , ihuge ) valu = huge ( valu ) ierr =- 1 endif endif end subroutine a2i !---------------------------------------------------------------------------------------------------------------------------------- subroutine a2d ( chars , valu , ierr , onerr ) ! ident_15=\"@(#) M_CLI2 a2d(3fp) subroutine returns double value from string\" ! 1989,2016 John S. Urban. ! ! o works with any g-format input, including integer, real, and exponential. ! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. ! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. ! IERR will still be non-zero in this case. !---------------------------------------------------------------------------------------------------------------------------------- character ( len =* ), intent ( in ) :: chars ! input string character ( len = :), allocatable :: local_chars doubleprecision , intent ( out ) :: valu ! value read from input string integer , intent ( out ) :: ierr ! error flag (0 == no error) class ( * ), optional , intent ( in ) :: onerr !---------------------------------------------------------------------------------------------------------------------------------- character ( len =* ), parameter :: fmt = \"('(bn,g',i5,'.0)')\" ! format used to build frmt character ( len = 15 ) :: frmt ! holds format built to read input string character ( len = 256 ) :: msg ! hold message from I/O errors integer :: intg integer :: pnd integer :: basevalue , ivalu character ( len = 3 ), save :: nan_string = 'NaN' !---------------------------------------------------------------------------------------------------------------------------------- ierr = 0 ! initialize error flag to zero local_chars = unquote ( chars ) msg = '' if ( len ( local_chars ) == 0 ) local_chars = ' ' local_chars = replace_str ( local_chars , ',' , '' ) ! remove any comma characters pnd = scan ( local_chars , '#:' ) if ( pnd /= 0 ) then write ( frmt , fmt ) pnd - 1 ! build format of form '(BN,Gn.0)' read ( local_chars (: pnd - 1 ), fmt = frmt , iostat = ierr , iomsg = msg ) basevalue ! try to read value from string if ( decodebase ( local_chars ( pnd + 1 :), basevalue , ivalu )) then valu = real ( ivalu , kind = kind ( 0.0d0 )) else valu = 0.0d0 ierr =- 1 endif else select case ( local_chars ( 1 : 1 )) case ( 'z' , 'Z' , 'h' , 'H' ) ! assume hexadecimal write ( frmt , \"('(Z',i0,')')\" ) len ( local_chars ) read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case ( 'b' , 'B' ) ! assume binary (base 2) write ( frmt , \"('(B',i0,')')\" ) len ( local_chars ) read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case ( 'o' , 'O' ) ! assume octal write ( frmt , \"('(O',i0,')')\" ) len ( local_chars ) read ( local_chars ( 2 :), frmt , iostat = ierr , iomsg = msg ) intg valu = dble ( intg ) case default write ( frmt , fmt ) len ( local_chars ) ! build format of form '(BN,Gn.0)' read ( local_chars , fmt = frmt , iostat = ierr , iomsg = msg ) valu ! try to read value from string end select endif if ( ierr /= 0 ) then ! if an error occurred ierr will be non-zero. if ( present ( onerr )) then select type ( onerr ) type is ( integer ) valu = onerr type is ( real ) valu = onerr type is ( doubleprecision ) valu = onerr end select else ! set return value to NaN read ( nan_string , '(f3.3)' ) valu endif if ( local_chars /= 'eod' ) then ! print warning message except for special value \"eod\" call journal ( '*a2d* - cannot produce number from string [' // trim ( chars ) // ']' ) if ( msg /= '' ) then call journal ( '*a2d* - [' // trim ( msg ) // ']' ) endif endif endif end subroutine a2d !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified !! delimiters !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine split(input_line,array,delimiters,order,nulls) !! !! character(len=*),intent(in) :: input_line !! character(len=:),allocatable,intent(out) :: array(:) !! character(len=*),optional,intent(in) :: delimiters !! character(len=*),optional,intent(in) :: order !! character(len=*),optional,intent(in) :: nulls !!##DESCRIPTION !! SPLIT(3f) parses a string using specified delimiter characters and !! store tokens into an allocatable array !! !!##OPTIONS !! !! INPUT_LINE Input string to tokenize !! !! ARRAY Output array of tokens !! !! DELIMITERS List of delimiter characters. !! The default delimiters are the \"whitespace\" characters !! (space, tab,new line, vertical tab, formfeed, carriage !! return, and null). You may specify an alternate set of !! delimiter characters. !! !! Multi-character delimiters are not supported (Each !! character in the DELIMITERS list is considered to be !! a delimiter). !! !! Quoting of delimiter characters is not supported. !! !! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. !! By default ARRAY contains the tokens having parsed !! the INPUT_LINE from left to right. If ORDER='RIGHT' !! or ORDER='REVERSE' the parsing goes from right to left. !! !! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. !! By default adjacent delimiters in the input string !! do not create an empty string in the output array. if !! NULLS='return' adjacent delimiters create an empty element !! in the output ARRAY. If NULLS='ignoreend' then only !! trailing delimiters at the right of the string are ignored. !! !!##EXAMPLES !! !! Sample program: !! !! program demo_split !! use M_CLI2, only: split !! character(len=*),parameter :: & !! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' !! character(len=:),allocatable :: array(:) ! output array of tokens !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,'(80(\"=\"))') !! write(*,*)'typical call:' !! CALL split(line,array) !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)'custom list of delimiters (colon and vertical line):' !! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)& !! &'custom list of delimiters, reverse array order and count null fields:' !! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! write(*,'(80(\"-\"))') !! write(*,*)'INPUT LINE:['//LINE//']' !! write(*,*)& !! &'default delimiters and reverse array order and return null fields:' !! CALL split(line,array,delimiters='',order='reverse',nulls='return') !! write(*,'(i0,\" ==> \",a)')(i,trim(array(i)),i=1,size(array)) !! write(*,*)'SIZE:',SIZE(array) !! end program demo_split !! !! Output !! !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > =========================================================================== !! > typical call: !! > 1 ==> aBcdef !! > 2 ==> ghijklmnop !! > 3 ==> qrstuvwxyz !! > 4 ==> 1:|:2 !! > 5 ==> 333|333 !! > 6 ==> a !! > 7 ==> B !! > 8 ==> cc !! > SIZE: 8 !! > -------------------------------------------------------------------------- !! > custom list of delimiters (colon and vertical line): !! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > 2 ==> 2 333 !! > 3 ==> 333 a B cc !! > SIZE: 3 !! > -------------------------------------------------------------------------- !! > custom list of delimiters, reverse array order and return null fields: !! > 1 ==> 333 a B cc !! > 2 ==> 2 333 !! > 3 ==> !! > 4 ==> !! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 !! > SIZE: 5 !! > -------------------------------------------------------------------------- !! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] !! > default delimiters and reverse array order and count null fields: !! > 1 ==> !! > 2 ==> !! > 3 ==> !! > 4 ==> cc !! > 5 ==> B !! > 6 ==> a !! > 7 ==> 333|333 !! > 8 ==> !! > 9 ==> !! > 10 ==> !! > 11 ==> !! > 12 ==> 1:|:2 !! > 13 ==> !! > 14 ==> qrstuvwxyz !! > 15 ==> ghijklmnop !! > 16 ==> !! > 17 ==> !! > 18 ==> aBcdef !! > 19 ==> !! > 20 ==> !! > SIZE: 20 !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain subroutine split ( input_line , array , delimiters , order , nulls ) !----------------------------------------------------------------------------------------------------------------------------------- ! ident_16=\"@(#) M_CLI2 split(3f) parse string on delimiter characters and store tokens into an allocatable array\" ! John S. Urban !----------------------------------------------------------------------------------------------------------------------------------- intrinsic index , min , present , len !----------------------------------------------------------------------------------------------------------------------------------- ! given a line of structure \" par1 par2 par3 ... parn \" store each par(n) into a separate variable in array. ! o by default adjacent delimiters in the input string do not create an empty string in the output array ! o no quoting of delimiters is supported character ( len =* ), intent ( in ) :: input_line ! input string to tokenize character ( len =* ), optional , intent ( in ) :: delimiters ! list of delimiter characters character ( len =* ), optional , intent ( in ) :: order ! order of output array sequential|[reverse|right] character ( len =* ), optional , intent ( in ) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend character ( len = :), allocatable , intent ( out ) :: array (:) ! output array of tokens !----------------------------------------------------------------------------------------------------------------------------------- integer :: n ! max number of strings INPUT_LINE could split into if all delimiter integer , allocatable :: ibegin (:) ! positions in input string where tokens start integer , allocatable :: iterm (:) ! positions in input string where tokens end character ( len = :), allocatable :: dlim ! string containing delimiter characters character ( len = :), allocatable :: ordr ! string containing order keyword character ( len = :), allocatable :: nlls ! string containing nulls keyword integer :: ii , iiii ! loop parameters used to control print order integer :: icount ! number of tokens found integer :: iilen ! length of input string with trailing spaces trimmed integer :: i10 , i20 , i30 ! loop counters integer :: icol ! pointer into input string as it is being parsed integer :: idlim ! number of delimiter characters integer :: ifound ! where next delimiter character is found in remaining input string data integer :: inotnull ! count strings not composed of delimiters integer :: ireturn ! number of tokens returned integer :: imax ! length of longest token !----------------------------------------------------------------------------------------------------------------------------------- ! decide on value for optional DELIMITERS parameter if ( present ( delimiters )) then ! optional delimiter list was present if ( delimiters /= '' ) then ! if DELIMITERS was specified and not null use it dlim = delimiters else ! DELIMITERS was specified on call as empty string dlim = ' ' // char ( 9 ) // char ( 10 ) // char ( 11 ) // char ( 12 ) // char ( 13 ) // char ( 0 ) // ',:' ! use default delimiter when not specified endif else ! no delimiter value was specified dlim = ' ' // char ( 9 ) // char ( 10 ) // char ( 11 ) // char ( 12 ) // char ( 13 ) // char ( 0 ) // ',:' ! use default delimiter when not specified endif idlim = len ( dlim ) ! dlim a lot of blanks on some machines if dlim is a big string !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( order )) then ; ordr = lower ( adjustl ( order )); else ; ordr = 'sequential' ; endif ! decide on value for optional ORDER parameter if ( present ( nulls )) then ; nlls = lower ( adjustl ( nulls )); else ; nlls = 'ignore' ; endif ! optional parameter !----------------------------------------------------------------------------------------------------------------------------------- n = len ( input_line ) + 1 ! max number of strings INPUT_LINE could split into if all delimiter if ( allocated ( ibegin )) deallocate ( ibegin ) !x! intel compiler says allocated already ??? allocate ( ibegin ( n )) ! allocate enough space to hold starting location of tokens if string all tokens if ( allocated ( iterm )) deallocate ( iterm ) !x! intel compiler says allocated already ??? allocate ( iterm ( n )) ! allocate enough space to hold ending location of tokens if string all tokens ibegin (:) = 1 iterm (:) = 1 !----------------------------------------------------------------------------------------------------------------------------------- iilen = len ( input_line ) ! IILEN is the column position of the last non-blank character icount = 0 ! how many tokens found inotnull = 0 ! how many tokens found not composed of delimiters imax = 0 ! length of longest token found if ( iilen > 0 ) then ! there is at least one non-delimiter in INPUT_LINE if get here icol = 1 ! initialize pointer into input line INFINITE : do i30 = 1 , iilen , 1 ! store into each array element ibegin ( i30 ) = icol ! assume start new token on the character if ( index ( dlim ( 1 : idlim ), input_line ( icol : icol )) == 0 ) then ! if current character is not a delimiter iterm ( i30 ) = iilen ! initially assume no more tokens do i10 = 1 , idlim ! search for next delimiter ifound = index ( input_line ( ibegin ( i30 ): iilen ), dlim ( i10 : i10 )) IF ( ifound > 0 ) then iterm ( i30 ) = min ( iterm ( i30 ), ifound + ibegin ( i30 ) - 2 ) endif enddo icol = iterm ( i30 ) + 2 ! next place to look as found end of this token inotnull = inotnull + 1 ! increment count of number of tokens not composed of delimiters else ! character is a delimiter for a null string iterm ( i30 ) = icol - 1 ! record assumed end of string. Will be less than beginning icol = icol + 1 ! advance pointer into input string endif imax = max ( imax , iterm ( i30 ) - ibegin ( i30 ) + 1 ) icount = i30 ! increment count of number of tokens found if ( icol > iilen ) then ! no text left exit INFINITE endif enddo INFINITE endif !----------------------------------------------------------------------------------------------------------------------------------- select case ( trim ( adjustl ( nlls ))) case ( 'ignore' , '' , 'ignoreend' ) ireturn = inotnull case default ireturn = icount end select if ( allocated ( array )) deallocate ( array ) allocate ( character ( len = imax ) :: array ( ireturn )) ! allocate the array to return !allocate(array(ireturn)) ! allocate the array to turn !----------------------------------------------------------------------------------------------------------------------------------- select case ( trim ( adjustl ( ordr ))) ! decide which order to store tokens case ( 'reverse' , 'right' ) ; ii = ireturn ; iiii =- 1 ! last to first case default ; ii = 1 ; iiii = 1 ! first to last end select !----------------------------------------------------------------------------------------------------------------------------------- do i20 = 1 , icount ! fill the array with the tokens that were found if ( iterm ( i20 ) < ibegin ( i20 )) then select case ( trim ( adjustl ( nlls ))) case ( 'ignore' , '' , 'ignoreend' ) case default array ( ii ) = ' ' ii = ii + iiii end select else array ( ii ) = input_line ( ibegin ( i20 ): iterm ( i20 )) ii = ii + iiii endif enddo !----------------------------------------------------------------------------------------------------------------------------------- end subroutine split !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one !! substring for another in string !! (LICENSE:PD) !! !!##SYNOPSIS !! !! function replace_str(targetline,old,new,range,ierr) result (newline) !! !! character(len=*) :: targetline !! character(len=*),intent(in) :: old !! character(len=*),intent(in) :: new !! integer,intent(in),optional :: range(2) !! integer,intent(out),optional :: ierr !! logical,intent(in),optional :: clip !! character(len=:),allocatable :: newline !!##DESCRIPTION !! Globally replace one substring for another in string. !! Either CMD or OLD and NEW must be specified. !! !!##OPTIONS !! targetline input line to be changed !! old old substring to replace !! new new substring !! range if present, only change range(1) to range(2) of !! occurrences of old string !! ierr error code. If ier = -1 bad directive, >= 0 then !! count of changes made !! clip whether to return trailing spaces or not. Defaults to .false. !!##RETURNS !! newline allocatable string returned !! !!##EXAMPLES !! !! Sample Program: !! !! program demo_replace_str !! use M_CLI2, only : replace_str !! implicit none !! character(len=:),allocatable :: targetline !! !! targetline='this is the input string' !! !! call testit('th','TH','THis is THe input string') !! !! ! a null old substring means \"at beginning of line\" !! call testit('','BEFORE:', 'BEFORE:THis is THe input string') !! !! ! a null new string deletes occurrences of the old substring !! call testit('i','', 'BEFORE:THs s THe nput strng') !! !! targetline=replace_str('a b ab baaa aaaa','a','A') !! write(*,*)'replace a with A ['//targetline//']' !! !! write(*,*)'Examples of the use of RANGE=' !! !! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) !! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) !! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' !! !! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa',& !! & 'aa','CCCC',range=[3,5]) !! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' !! !! contains !! subroutine testit(old,new,expected) !! character(len=*),intent(in) :: old,new,expected !! write(*,*)repeat('=',79) !! write(*,*)':STARTED ['//targetline//']' !! write(*,*)':OLD['//old//']', ' NEW['//new//']' !! targetline=replace_str(targetline,old,new) !! write(*,*)':GOT ['//targetline//']' !! write(*,*)':EXPECTED['//expected//']' !! write(*,*)':TEST [',targetline == expected,']' !! end subroutine testit !! !! end program demo_replace_str !! !! Expected output !! !! =============================================================================== !! STARTED [this is the input string] !! OLD[th] NEW[TH] !! GOT [THis is THe input string] !! EXPECTED[THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [THis is THe input string] !! OLD[] NEW[BEFORE:] !! GOT [BEFORE:THis is THe input string] !! EXPECTED[BEFORE:THis is THe input string] !! TEST [ T ] !! =============================================================================== !! STARTED [BEFORE:THis is THe input string] !! OLD[i] NEW[] !! GOT [BEFORE:THs s THe nput strng] !! EXPECTED[BEFORE:THs s THe nput strng] !! TEST [ T ] !! replace a with A [A b Ab bAAA AAAA] !! Examples of the use of RANGE= !! replace a with A instances 3 to 5 [a b ab bAAA aaaa] !! replace a with null instances 3 to 5 [a b ab b aaaa] !! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC !! a a a aa aaaaaa] !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function replace_str ( targetline , old , new , ierr , range ) result ( newline ) ! ident_17=\"@(#) M_CLI2 replace_str(3f) Globally replace one substring for another in string\" !----------------------------------------------------------------------------------------------------------------------------------- ! parameters character ( len =* ), intent ( in ) :: targetline ! input line to be changed character ( len =* ), intent ( in ) :: old ! old substring to replace character ( len =* ), intent ( in ) :: new ! new substring integer , intent ( out ), optional :: ierr ! error code. If ierr = -1 bad directive, >=0 then ierr changes made integer , intent ( in ), optional :: range ( 2 ) ! start and end of which changes to make !----------------------------------------------------------------------------------------------------------------------------------- ! returns character ( len = :), allocatable :: newline ! output string buffer !----------------------------------------------------------------------------------------------------------------------------------- ! local integer :: icount , ichange integer :: original_input_length integer :: len_old , len_new integer :: ladd integer :: left_margin , right_margin integer :: ind integer :: ic integer :: iichar integer :: range_local ( 2 ) !----------------------------------------------------------------------------------------------------------------------------------- icount = 0 ! initialize error flag/change count ichange = 0 ! initialize error flag/change count original_input_length = len_trim ( targetline ) ! get non-blank length of input line len_old = len ( old ) ! length of old substring to be replaced len_new = len ( new ) ! length of new substring to replace old substring left_margin = 1 ! left_margin is left margin of window to change right_margin = len ( targetline ) ! right_margin is right margin of window to change newline = '' ! begin with a blank line as output string !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( range )) then range_local = range else range_local = [ 1 , original_input_length ] endif !----------------------------------------------------------------------------------------------------------------------------------- if ( len_old == 0 ) then ! c//new/ means insert new at beginning of line (or left margin) iichar = len_new + original_input_length if ( len_new > 0 ) then newline = new (: len_new ) // targetline ( left_margin : original_input_length ) else newline = targetline ( left_margin : original_input_length ) endif ichange = 1 ! made one change. actually, c/// should maybe return 0 if ( present ( ierr )) ierr = ichange return endif !----------------------------------------------------------------------------------------------------------------------------------- iichar = left_margin ! place to put characters into output string ic = left_margin ! place looking at in input string loop : do ind = index ( targetline ( ic :), old (: len_old )) + ic - 1 ! try finding start of OLD in remaining part of input in change window if ( ind == ic - 1. or . ind > right_margin ) then ! did not find old string or found old string past edit window exit loop ! no more changes left to make endif icount = icount + 1 ! found an old string to change, so increment count of change candidates if ( ind > ic ) then ! if found old string past at current position in input string copy unchanged ladd = ind - ic ! find length of character range to copy as-is from input to output newline = newline (: iichar - 1 ) // targetline ( ic : ind - 1 ) iichar = iichar + ladd endif if ( icount >= range_local ( 1 ). and . icount <= range_local ( 2 )) then ! check if this is an instance to change or keep ichange = ichange + 1 if ( len_new /= 0 ) then ! put in new string newline = newline (: iichar - 1 ) // new (: len_new ) iichar = iichar + len_new endif else if ( len_old /= 0 ) then ! put in copy of old string newline = newline (: iichar - 1 ) // old (: len_old ) iichar = iichar + len_old endif endif ic = ind + len_old enddo loop !----------------------------------------------------------------------------------------------------------------------------------- select case ( ichange ) case ( 0 ) ! there were no changes made to the window newline = targetline ! if no changes made output should be input case default if ( ic <= len ( targetline )) then ! if there is more after last change on original line add it newline = newline (: iichar - 1 ) // targetline ( ic : max ( ic , original_input_length )) endif end select if ( present ( ierr )) ierr = ichange !----------------------------------------------------------------------------------------------------------------------------------- end function replace_str !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with !! list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! function quote(str,mode,clip) result (quoted_str) !! !! character(len=*),intent(in) :: str !! character(len=*),optional,intent(in) :: mode !! logical,optional,intent(in) :: clip !! character(len=:),allocatable :: quoted_str !!##DESCRIPTION !! Add quotes to a CHARACTER variable as if it was written using !! list-directed input. This is particularly useful for processing !! strings to add to CSV files. !! !!##OPTIONS !! str input string to add quotes to, using the rules of !! list-directed input (single quotes are replaced by two !! adjacent quotes) !! mode alternate quoting methods are supported: !! !! DOUBLE default. replace quote with double quotes !! ESCAPE replace quotes with backslash-quote instead !! of double quotes !! !! clip default is to trim leading and trailing spaces from the !! string. If CLIP !! is .FALSE. spaces are not trimmed !! !!##RESULT !! quoted_str The output string, which is based on adding quotes to STR. !!##EXAMPLE !! !! Sample program: !! !! program demo_quote !! use M_CLI2, only : quote !! implicit none !! character(len=:),allocatable :: str !! character(len=1024) :: msg !! integer :: ios !! character(len=80) :: inline !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)inline !! if(ios /= 0)then !! write(*,*)trim(inline) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'ORIGINAL ['//trim(inline)//']' !! !! ! the string processed by quote(3f) !! str=quote(inline) !! write(*,'(a)')'QUOTED ['//str//']' !! !! ! write the string list-directed to compare the results !! write(*,'(a)',iostat=ios,iomsg=msg) 'LIST DIRECTED:' !! write(*,*,iostat=ios,iomsg=msg,delim='none') inline !! write(*,*,iostat=ios,iomsg=msg,delim='quote') inline !! write(*,*,iostat=ios,iomsg=msg,delim='apostrophe') inline !! enddo !! end program demo_quote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain function quote ( str , mode , clip ) result ( quoted_str ) character ( len =* ), intent ( in ) :: str ! the string to be quoted character ( len =* ), optional , intent ( in ) :: mode logical , optional , intent ( in ) :: clip logical :: clip_local character ( len = :), allocatable :: quoted_str character ( len = 1 ), parameter :: double_quote = '\"' character ( len = 20 ) :: local_mode if ( present ( mode )) then local_mode = mode else local_mode = 'DOUBLE' endif if ( present ( clip )) then clip_local = clip else clip_local = . false . endif if ( clip_local ) then quoted_str = adjustl ( str ) else quoted_str = str endif select case ( lower ( local_mode )) case ( 'double' ) quoted_str = double_quote // trim ( replace_str ( quoted_str , '\"' , '\"\"' )) // double_quote case ( 'escape' ) quoted_str = double_quote // trim ( replace_str ( quoted_str , '\"' , '\\\"' )) // double_quote case default call journal ( '*quote* ERROR: unknown quote mode ' , local_mode ) quoted_str = str end select end function quote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read !! with list-directed input !! (LICENSE:PD) !!##SYNOPSIS !! !! pure function unquote(quoted_str,esc) result (unquoted_str) !! !! character(len=*),intent(in) :: quoted_str !! character(len=1),optional,intent(in) :: esc !! character(len=:),allocatable :: unquoted_str !!##DESCRIPTION !! Remove quotes from a CHARACTER variable as if it was read using !! list-directed input. This is particularly useful for processing !! tokens read from input such as CSV files. !! !! Fortran can now read using list-directed input from an internal file, !! which should handle quoted strings, but list-directed input does not !! support escape characters, which UNQUOTE(3f) does. !!##OPTIONS !! quoted_str input string to remove quotes from, using the rules of !! list-directed input (two adjacent quotes inside a quoted !! region are replaced by a single quote, a single quote or !! double quote is selected as the delimiter based on which !! is encountered first going from left to right, ...) !! esc optional character used to protect the next quote !! character from being processed as a quote, but simply as !! a plain character. !!##RESULT !! unquoted_str The output string, which is based on removing quotes !! from quoted_str. !!##EXAMPLE !! !! Sample program: !! !! program demo_unquote !! use M_CLI2, only : unquote !! implicit none !! character(len=128) :: quoted_str !! character(len=:),allocatable :: unquoted_str !! character(len=1),parameter :: esc='\\' !! character(len=1024) :: msg !! integer :: ios !! character(len=1024) :: dummy !! do !! write(*,'(a)',advance='no')'Enter test string:' !! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str !! if(ios /= 0)then !! write(*,*)trim(msg) !! exit !! endif !! !! ! the original string !! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' !! !! ! the string processed by unquote(3f) !! unquoted_str=unquote(trim(quoted_str),esc) !! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' !! !! ! read the string list-directed to compare the results !! read(quoted_str,*,iostat=ios,iomsg=msg)dummy !! if(ios /= 0)then !! write(*,*)trim(msg) !! else !! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' !! endif !! enddo !! end program demo_unquote !! !!##AUTHOR !! John S. Urban !!##LICENSE !! Public Domain pure function unquote ( quoted_str , esc ) result ( unquoted_str ) character ( len =* ), intent ( in ) :: quoted_str ! the string to be unquoted character ( len = 1 ), optional , intent ( in ) :: esc ! escape character character ( len = :), allocatable :: unquoted_str integer :: inlen character ( len = 1 ), parameter :: single_quote = \"'\" character ( len = 1 ), parameter :: double_quote = '\"' integer :: quote ! whichever quote is to be used integer :: before integer :: current integer :: iesc integer :: iput integer :: i logical :: inside !----------------------------------------------------------------------------------------------------------------------------------- if ( present ( esc )) then ! select escape character as specified character or special value meaning not set iesc = ichar ( esc ) ! allow for an escape character else iesc =- 1 ! set to value that matches no character endif !----------------------------------------------------------------------------------------------------------------------------------- inlen = len ( quoted_str ) ! find length of input string if ( allocated ( unquoted_str )) deallocate ( unquoted_str ) allocate ( character ( len = inlen ) :: unquoted_str ) ! initially make output string length of input string !----------------------------------------------------------------------------------------------------------------------------------- if ( inlen >= 1 ) then ! double_quote is the default quote unless the first character is single_quote if ( quoted_str ( 1 : 1 ) == single_quote ) then quote = ichar ( single_quote ) else quote = ichar ( double_quote ) endif else quote = ichar ( double_quote ) endif !----------------------------------------------------------------------------------------------------------------------------------- before =- 2 ! initially set previous character to impossible value unquoted_str (:) = '' ! initialize output string to null string iput = 1 inside = . false . STEPTHROUGH : do i = 1 , inlen current = ichar ( quoted_str ( i : i )) if ( before == iesc ) then ! if previous character was escape use current character unconditionally iput = iput - 1 ! backup unquoted_str ( iput : iput ) = char ( current ) iput = iput + 1 before =- 2 ! this could be second esc or quote elseif ( current == quote ) then ! if current is a quote it depends on whether previous character was a quote if ( before == quote ) then unquoted_str ( iput : iput ) = char ( quote ) ! this is second quote so retain it iput = iput + 1 before =- 2 elseif (. not . inside . and . before /= iesc ) then inside = . true . else ! this is first quote so ignore it except remember it in case next is a quote before = current endif else unquoted_str ( iput : iput ) = char ( current ) iput = iput + 1 before = current endif enddo STEPTHROUGH !----------------------------------------------------------------------------------------------------------------------------------- unquoted_str = unquoted_str (: iput - 1 ) !----------------------------------------------------------------------------------------------------------------------------------- end function unquote !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! !! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base !! [2-36] to base 10 number !! (LICENSE:PD) !! !!##SYNOPSIS !! !! logical function decodebase(string,basein,out10) !! !! character(len=*),intent(in) :: string !! integer,intent(in) :: basein !! integer,intent(out) :: out10 !!##DESCRIPTION !! !! Convert a numeric string representing a whole number in base BASEIN !! to base 10. The function returns FALSE if BASEIN is not in the range !! [2..36] or if string STRING contains invalid characters in base BASEIN !! or if result OUT10 is too big !! !! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. !! !!##OPTIONS !! string input string. It represents a whole number in !! the base specified by BASEIN unless BASEIN is set !! to zero. When BASEIN is zero STRING is assumed to !! be of the form BASE#VALUE where BASE represents !! the function normally provided by BASEIN. !! basein base of input string; either 0 or from 2 to 36. !! out10 output value in base 10 !! !!##EXAMPLE !! !! Sample program: !! !! program demo_decodebase !! use M_CLI2, only : codebase, decodebase !! implicit none !! integer :: ba,bd !! character(len=40) :: x,y !! integer :: r !! !! print *,' BASE CONVERSION' !! write(*,'(\"Start Base (2 to 36): \")',advance='no'); read *, bd !! write(*,'(\"Arrival Base (2 to 36): \")',advance='no'); read *, ba !! INFINITE: do !! print *,'' !! write(*,'(\"Enter number in start base: \")',advance='no'); read *, x !! if(x == '0') exit INFINITE !! if(decodebase(x,bd,r)) then !! if(codebase(r,ba,y)) then !! write(*,'(\"In base \",I2,\": \",A20)') ba, y !! else !! print *,'Error in coding number.' !! endif !! else !! print *,'Error in decoding number.' !! endif !! enddo INFINITE !! !! end program demo_decodebase !! !!##AUTHOR !! John S. Urban !! !! Ref.: \"Math matiques en Turbo-Pascal by !! M. Ducamp and A. Reverchon (2), !! Eyrolles, Paris, 1988\". !! !! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) !! !!##LICENSE !! Public Domain logical function decodebase ( string , basein , out_baseten ) ! ident_18=\"@(#) M_CLI2 decodebase(3f) convert whole number string in base [2-36] to base 10 number\" character ( len =* ), intent ( in ) :: string integer , intent ( in ) :: basein integer , intent ( out ) :: out_baseten character ( len = len ( string )) :: string_local integer :: long , i , j , k real :: y real :: mult character ( len = 1 ) :: ch real , parameter :: XMAXREAL = real ( huge ( 1 )) integer :: out_sign integer :: basein_local integer :: ipound integer :: ierr string_local = upper ( trim ( adjustl ( string ))) decodebase = . false . ipound = index ( string_local , '#' ) ! determine if in form [-]base#whole if ( basein == 0. and . ipound > 1 ) then ! split string into two values call a2i ( string_local (: ipound - 1 ), basein_local , ierr ) ! get the decimal value of the base string_local = string_local ( ipound + 1 :) ! now that base is known make string just the value if ( basein_local >= 0 ) then ! allow for a negative sign prefix out_sign = 1 else out_sign =- 1 endif basein_local = abs ( basein_local ) else ! assume string is a simple positive value basein_local = abs ( basein ) out_sign = 1 endif out_baseten = 0 y = 0.0 ALL : if ( basein_local < 2. or . basein_local > 36 ) then print * , '(*decodebase* ERROR: Base must be between 2 and 36. base=' , basein_local else ALL out_baseten = 0 ; y = 0.0 ; mult = 1.0 long = LEN_TRIM ( string_local ) do i = 1 , long k = long + 1 - i ch = string_local ( k : k ) IF ( CH == '-' . AND . K == 1 ) THEN out_sign =- 1 cycle endif if ( ch < '0' . or . ch > 'Z' . or .( ch > '9' . and . ch < 'A' )) then write ( * , * ) '*decodebase* ERROR: invalid character ' , ch exit ALL endif if ( ch <= '9' ) then j = IACHAR ( ch ) - IACHAR ( '0' ) else j = IACHAR ( ch ) - IACHAR ( 'A' ) + 10 endif if ( j >= basein_local ) then exit ALL endif y = y + mult * j if ( mult > XMAXREAL / basein_local ) then exit ALL endif mult = mult * basein_local enddo decodebase = . true . out_baseten = nint ( out_sign * y ) * sign ( 1 , basein ) endif ALL end function decodebase !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! locate_(3f) - [M_CLI2] finds the index where a string is found or !! should be in a sorted array !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine locate_(list,value,place,ier,errmsg) !! !! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! integer, intent(out) :: PLACE !! !! integer, intent(out),optional :: IER !! character(len=*),intent(out),optional :: ERRMSG !! !!##DESCRIPTION !! !! LOCATE_(3f) finds the index where the VALUE is found or should !! be found in an array. The array must be sorted in descending !! order (highest at top). If VALUE is not found it returns the index !! where the name should be placed at with a negative sign. !! !! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL,INTEGER) !! !!##OPTIONS !! !! VALUE the value to locate in the list. !! LIST is the list array. !! !!##RETURNS !! PLACE is the subscript that the entry was found at if it is !! greater than zero(0). !! !! If PLACE is negative, the absolute value of !! PLACE indicates the subscript value where the !! new entry should be placed in order to keep the !! list alphabetized. !! !! IER is zero(0) if no error occurs. !! If an error occurs and IER is not !! present, the program is stopped. !! !! ERRMSG description of any error !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_locate !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),intent(in),allocatable :: arr(:) !! character(len=*),intent(in) :: string !! integer :: place, plus, ii, end !! ! find where string is or should be !! call locate_(arr,string,place) !! write(*,*)'for \"'//string//'\" index is ',place, size(arr) !! ! if string was not found insert it !! if(place < 1)then !! plus=abs(place) !! ii=len(arr) !! end=size(arr) !! ! empty array !! if(end == 0)then !! arr=[character(len=ii) :: string ] !! ! put in front of array !! elseif(plus == 1)then !! arr=[character(len=ii) :: string, arr] !! ! put at end of array !! elseif(plus == end)then !! arr=[character(len=ii) :: arr, string ] !! ! put in middle of array !! else !! arr=[character(len=ii) :: arr(:plus-1), string,arr(plus:) ] !! endif !! ! show array !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! endif !! end subroutine update_dic !! end program demo_locate !! !! Results: !! !! for \"b\" index is 2 5 !! for \"[\" index is -4 5 !! SIZE=5 xxx,b,aaa,[,ZZZ, !! for \"c\" index is -2 6 !! SIZE=6 xxx,c,b,aaa,[,ZZZ, !! for \"ZZ\" index is -7 7 !! SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! for \"ZZZZ\" index is -6 8 !! SIZE=8 xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! for \"z\" index is -1 9 !! SIZE=9 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine locate_c ( list , value , place , ier , errmsg ) ! ident_19=\"@(#) M_CLI2 locate_c(3f) find PLACE in sorted character array LIST where VALUE can be found or should be placed\" character ( len =* ), intent ( in ) :: value integer , intent ( out ) :: place character ( len = :), allocatable :: list (:) integer , intent ( out ), optional :: ier character ( len =* ), intent ( out ), optional :: errmsg integer :: i character ( len = :), allocatable :: message integer :: arraysize integer :: maxtry integer :: imin , imax integer :: error if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif arraysize = size ( list ) error = 0 if ( arraysize == 0 ) then maxtry = 0 place =- 1 else maxtry = nint ( log ( float ( arraysize )) / log ( 2.0 ) + 1.0 ) place = ( arraysize + 1 ) / 2 endif imin = 1 imax = arraysize message = '' LOOP : block do i = 1 , maxtry if ( value == list ( PLACE )) then exit LOOP elseif ( value > list ( place )) then imax = place - 1 else imin = place + 1 endif if ( imin > imax ) then place =- imin if ( iabs ( place ) > arraysize ) then ! ran off end of list. Where new value should go or an unsorted input array' exit LOOP endif exit LOOP endif place = ( imax + imin ) / 2 if ( place > arraysize . or . place <= 0 ) then message = '*locate_* error: search is out of bounds of list. Probably an unsorted input array' error =- 1 exit LOOP endif enddo message = '*locate_* exceeded allowed tries. Probably an unsorted input array' endblock LOOP if ( present ( ier )) then ier = error elseif ( error /= 0 ) then write ( warn , * ) message // ' VALUE=' , trim ( value ) // ' PLACE=' , place call mystop ( - 24 , '(*locate_c* ' // message ) endif if ( present ( errmsg )) then errmsg = message endif end subroutine locate_c !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! remove_(3f) - [M_CLI2] remove entry from an allocatable array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine remove_(list,place) !! !! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) !! integer, intent(out) :: PLACE !! !!##DESCRIPTION !! !! Remove a value from an allocatable array at the specified index. !! The array is assumed to be sorted in descending order. It may be of !! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. !! !!##OPTIONS !! !! list is the list array. !! PLACE is the subscript for the entry that should be removed !! !!##EXAMPLES !! !! !! Sample program !! !! program demo_remove !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, remove_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! integer :: end !! !! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,1) !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! call remove_(arr,4) !! end=size(arr) !! write(*,'(\"SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! !! end program demo_remove !! !! Results: !! !! Expected output !! !! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, !! SIZE=7 bb,b,b,aaa,ZZZ,Z,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine remove_c ( list , place ) ! ident_20=\"@(#) M_CLI2 remove_c(3fp) remove string from allocatable string array at specified position\" character ( len = :), allocatable :: list (:) integer , intent ( in ) :: place integer :: ii , end if (. not . allocated ( list )) then list = [ character ( len = 2 ) :: ] endif ii = len ( list ) end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ character ( len = ii ) :: list (: place - 1 ) ] else list = [ character ( len = ii ) :: list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_c subroutine remove_l ( list , place ) ! ident_21=\"@(#) M_CLI2 remove_l(3fp) remove value from allocatable array at specified position\" logical , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ list (: place - 1 )] else list = [ list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_l subroutine remove_i ( list , place ) ! ident_22=\"@(#) M_CLI2 remove_i(3fp) remove value from allocatable array at specified position\" integer , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( place <= 0. or . place > end ) then ! index out of bounds of array elseif ( place == end ) then ! remove from array list = [ list (: place - 1 )] else list = [ list (: place - 1 ), list ( place + 1 :) ] endif end subroutine remove_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! replace_(3f) - [M_CLI2] replace entry in a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine replace_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer, intent(out) :: place !! !!##DESCRIPTION !! !! replace a value in an allocatable array at the specified index. Unless the !! array needs the string length to increase this is merely an assign of a value !! to an array element. !! !! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> !! It is assumed to be sorted in descending order without duplicate values. !! !! The value and list must be of the same type. !! !!##OPTIONS !! !! VALUE the value to place in the array !! LIST is the array. !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Replace key-value pairs in a dictionary !! !! program demo_replace !! use M_CLI2, only : insert_, locate_, replace_ !! ! Find if a key is in a list and insert it !! ! into the key list and value list if it is not present !! ! or replace the associated value if the key existed !! implicit none !! character(len=20) :: key !! character(len=100) :: val !! character(len=:),allocatable :: keywords(:) !! character(len=:),allocatable :: values(:) !! integer :: i !! integer :: place !! call update_dic('b','value of b') !! call update_dic('a','value of a') !! call update_dic('c','value of c') !! call update_dic('c','value of c again') !! call update_dic('d','value of d') !! call update_dic('a','value of a again') !! ! show array !! write(*,'(*(a,\"==>\",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) !! !! call locate_key('a',place) !! if(place > 0)then !! write(*,*)'The value of \"a\" is',trim(values(place)) !! else !! write(*,*)'\"a\" not found' !! endif !! !! contains !! subroutine update_dic(key,val) !! character(len=*),intent(in) :: key !! character(len=*),intent(in) :: val !! integer :: place !! !! ! find where string is or should be !! call locate_key(key,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(keywords,key,abs(place)) !! call insert_(values,val,abs(place)) !! else ! replace !! call replace_(values,val,place) !! endif !! !! end subroutine update_dic !! end program demo_replace !! !! Expected output !! !! d==>value of d !! c==>value of c again !! b==>value of b !! a==>value of a again !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine replace_c ( list , value , place ) ! ident_23=\"@(#) M_CLI2 replace_c(3fp) replace string in allocatable string array at specified position\" character ( len =* ), intent ( in ) :: value character ( len = :), allocatable :: list (:) character ( len = :), allocatable :: kludge (:) integer , intent ( in ) :: place integer :: ii integer :: tlen integer :: end if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif tlen = len_trim ( value ) end = size ( list ) if ( place < 0. or . place > end ) then write ( warn , * ) '*replace_c* error: index out of range. end=' , end , ' index=' , place elseif ( len_trim ( value ) <= len ( list )) then list ( place ) = value else ! increase length of variable ii = max ( tlen , len ( list )) kludge = [ character ( len = ii ) :: list ] list = kludge list ( place ) = value endif end subroutine replace_c subroutine replace_l ( list , value , place ) ! ident_24=\"@(#) M_CLI2 replace_l(3fp) place value into allocatable array at specified position\" logical , allocatable :: list (:) logical , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place > 0. and . place <= end ) then list ( place ) = value else ! put in middle of array write ( warn , * ) '*replace_l* error: index out of range. end=' , end , ' index=' , place endif end subroutine replace_l subroutine replace_i ( list , value , place ) ! ident_25=\"@(#) M_CLI2 replace_i(3fp) place value into allocatable array at specified position\" integer , intent ( in ) :: value integer , allocatable :: list (:) integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place > 0. and . place <= end ) then list ( place ) = value else ! put in middle of array write ( warn , * ) '*replace_i* error: index out of range. end=' , end , ' index=' , place endif end subroutine replace_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== !> !!##NAME !! insert_(3f) - [M_CLI2] insert entry into a string array at specified position !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine insert_(list,value,place) !! !! character(len=*)|doubleprecision|real|integer,intent(in) :: value !! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) !! integer,intent(in) :: place !! !!##DESCRIPTION !! !! Insert a value into an allocatable array at the specified index. !! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, !! REAL, or INTEGER) !! !!##OPTIONS !! !! list is the list array. Must be sorted in descending order. !! value the value to place in the array !! PLACE is the subscript that the entry should be placed at !! !!##EXAMPLES !! !! !! Find if a string is in a sorted array, and insert the string into !! the list if it is not present ... !! !! program demo_insert !! use M_sort, only : sort_shell !! use M_CLI2, only : locate_, insert_ !! implicit none !! character(len=:),allocatable :: arr(:) !! integer :: i !! !! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] !! ! make sure sorted in descending order !! call sort_shell(arr,order='d') !! ! add or replace values !! call update_dic(arr,'b') !! call update_dic(arr,'[') !! call update_dic(arr,'c') !! call update_dic(arr,'ZZ') !! call update_dic(arr,'ZZZ') !! call update_dic(arr,'ZZZZ') !! call update_dic(arr,'') !! call update_dic(arr,'z') !! !! contains !! subroutine update_dic(arr,string) !! character(len=:),allocatable :: arr(:) !! character(len=*) :: string !! integer :: place, end !! !! end=size(arr) !! ! find where string is or should be !! call locate_(arr,string,place) !! ! if string was not found insert it !! if(place < 1)then !! call insert_(arr,string,abs(place)) !! endif !! ! show array !! end=size(arr) !! write(*,'(\"array is now SIZE=\",i0,1x,*(a,\",\"))')end,(trim(arr(i)),i=1,end) !! !! end subroutine update_dic !! end program demo_insert !! !! Results: !! !! array is now SIZE=5 xxx,b,aaa,ZZZ,, !! array is now SIZE=6 xxx,b,aaa,[,ZZZ,, !! array is now SIZE=7 xxx,c,b,aaa,[,ZZZ,, !! array is now SIZE=8 xxx,c,b,aaa,[,ZZZ,ZZ,, !! array is now SIZE=9 xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! array is now SIZE=10 z,xxx,c,b,aaa,[,ZZZZ,ZZZ,ZZ,, !! !!##AUTHOR !! 1989,2017 John S. Urban !!##LICENSE !! Public Domain subroutine insert_c ( list , value , place ) ! ident_26=\"@(#) M_CLI2 insert_c(3fp) place string into allocatable string array at specified position\" character ( len =* ), intent ( in ) :: value character ( len = :), allocatable :: list (:) character ( len = :), allocatable :: kludge (:) integer , intent ( in ) :: place integer :: ii integer :: end if (. not . allocated ( list )) then list = [ character ( len = max ( len_trim ( value ), 2 )) :: ] endif ii = max ( len_trim ( value ), len ( list ), 2 ) end = size ( list ) if ( end == 0 ) then ! empty array list = [ character ( len = ii ) :: value ] elseif ( place == 1 ) then ! put in front of array kludge = [ character ( len = ii ) :: value , list ] list = kludge elseif ( place > end ) then ! put at end of array kludge = [ character ( len = ii ) :: list , value ] list = kludge elseif ( place >= 2. and . place <= end ) then ! put in middle of array kludge = [ character ( len = ii ) :: list (: place - 1 ), value , list ( place :) ] list = kludge else ! index out of range write ( warn , * ) '*insert_c* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_c subroutine insert_l ( list , value , place ) ! ident_27=\"@(#) M_CLI2 insert_l(3fp) place value into allocatable array at specified position\" logical , allocatable :: list (:) logical , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ logical :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place == 1 ) then ! put in front of array list = [ value , list ] elseif ( place > end ) then ! put at end of array list = [ list , value ] elseif ( place >= 2. and . place <= end ) then ! put in middle of array list = [ list (: place - 1 ), value , list ( place :) ] else ! index out of range write ( warn , * ) '*insert_l* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_l subroutine insert_i ( list , value , place ) ! ident_28=\"@(#) M_CLI2 insert_i(3fp) place value into allocatable array at specified position\" integer , allocatable :: list (:) integer , intent ( in ) :: value integer , intent ( in ) :: place integer :: end if (. not . allocated ( list )) then list = [ integer :: ] endif end = size ( list ) if ( end == 0 ) then ! empty array list = [ value ] elseif ( place == 1 ) then ! put in front of array list = [ value , list ] elseif ( place > end ) then ! put at end of array list = [ list , value ] elseif ( place >= 2. and . place <= end ) then ! put in middle of array list = [ list (: place - 1 ), value , list ( place :) ] else ! index out of range write ( warn , * ) '*insert_i* error: index out of range. end=' , end , ' index=' , place , ' value=' , value endif end subroutine insert_i !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine many_args ( n0 , g0 , n1 , g1 , n2 , g2 , n3 , g3 , n4 , g4 , n5 , g5 , n6 , g6 , n7 , g7 , n8 , g8 , n9 , g9 , & & na , ga , nb , gb , nc , gc , nd , gd , ne , ge , nf , gf , ng , gg , nh , gh , ni , gi , nj , gj ) ! ident_29=\"@(#) M_CLI2 many_args(3fp) allow for multiple calls to get_args(3f)\" character ( len =* ), intent ( in ) :: n0 , n1 character ( len =* ), intent ( in ), optional :: n2 , n3 , n4 , n5 , n6 , n7 , n8 , n9 , na , nb , nc , nd , ne , nf , ng , nh , ni , nj class ( * ), intent ( out ) :: g0 , g1 class ( * ), intent ( out ), optional :: g2 , g3 , g4 , g5 , g6 , g7 , g8 , g9 , ga , gb , gc , gd , ge , gf , gg , gh , gi , gj call get_generic ( n0 , g0 ) call get_generic ( n1 , g1 ) if ( present ( n2 ) . and . present ( g2 ) ) call get_generic ( n2 , g2 ) if ( present ( n3 ) . and . present ( g3 ) ) call get_generic ( n3 , g3 ) if ( present ( n4 ) . and . present ( g4 ) ) call get_generic ( n4 , g4 ) if ( present ( n5 ) . and . present ( g5 ) ) call get_generic ( n5 , g5 ) if ( present ( n6 ) . and . present ( g6 ) ) call get_generic ( n6 , g6 ) if ( present ( n7 ) . and . present ( g7 ) ) call get_generic ( n7 , g7 ) if ( present ( n8 ) . and . present ( g8 ) ) call get_generic ( n8 , g8 ) if ( present ( n9 ) . and . present ( g9 ) ) call get_generic ( n9 , g9 ) if ( present ( na ) . and . present ( ga ) ) call get_generic ( na , ga ) if ( present ( nb ) . and . present ( gb ) ) call get_generic ( nb , gb ) if ( present ( nc ) . and . present ( gc ) ) call get_generic ( nc , gc ) if ( present ( nd ) . and . present ( gd ) ) call get_generic ( nd , gd ) if ( present ( ne ) . and . present ( ge ) ) call get_generic ( ne , ge ) if ( present ( nf ) . and . present ( gf ) ) call get_generic ( nf , gf ) if ( present ( ng ) . and . present ( gg ) ) call get_generic ( ng , gg ) if ( present ( nh ) . and . present ( gh ) ) call get_generic ( nh , gh ) if ( present ( ni ) . and . present ( gi ) ) call get_generic ( ni , gi ) if ( present ( nj ) . and . present ( gj ) ) call get_generic ( nj , gj ) contains !=================================================================================================================================== function c ( generic ) class ( * ), intent ( in ) :: generic character ( len = :), allocatable :: c select type ( generic ) type is ( character ( len =* )); c = trim ( generic ) class default c = 'unknown' stop 'get_many:: parameter name is not character' end select end function c !=================================================================================================================================== subroutine get_generic ( name , generic ) use , intrinsic :: iso_fortran_env , only : real64 character ( len =* ), intent ( in ) :: name class ( * ), intent ( out ) :: generic select type ( generic ) type is ( integer ); call get_args ( name , generic ) type is ( real ); call get_args ( name , generic ) type is ( real ( kind = real64 )); call get_args ( name , generic ) type is ( logical ); call get_args ( name , generic ) !x!type is (character(len=:),allocatable ::); call get_args(name,generic) type is ( character ( len =* )); call get_args_fixed_length ( name , generic ) type is ( complex ); call get_args ( name , generic ) class default stop 'unknown type in *get_generic*' end select end subroutine get_generic !=================================================================================================================================== end subroutine many_args !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== function iget ( n ); integer :: iget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , iget ); end function iget function rget ( n ); real :: rget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , rget ); end function rget function dget ( n ); real ( kind = dp ) :: dget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , dget ); end function dget function sget ( n ); character ( len = :), allocatable :: sget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , sget ); end function sget function cget ( n ); complex :: cget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , cget ); end function cget function lget ( n ); logical :: lget ; character ( len =* ), intent ( in ) :: n ; call get_args ( n , lget ); end function lget function igs ( n ); integer , allocatable :: igs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , igs ); end function igs function rgs ( n ); real , allocatable :: rgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , rgs ); end function rgs function dgs ( n ); real ( kind = dp ), allocatable :: dgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , dgs ); end function dgs function sgs ( n , delims ) character ( len = :), allocatable :: sgs (:) character ( len =* ), optional , intent ( in ) :: delims character ( len =* ), intent ( in ) :: n call get_args ( n , sgs , delims ) end function sgs function cgs ( n ); complex , allocatable :: cgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , cgs ); end function cgs function lgs ( n ); logical , allocatable :: lgs (:); character ( len =* ), intent ( in ) :: n ; call get_args ( n , lgs ); end function lgs !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function ig () integer , allocatable :: ig (:) integer :: i , ierr if ( allocated ( ig )) deallocate ( ig ) allocate ( ig ( size ( unnamed ))) do i = 1 , size ( ig ) call a2i ( unnamed ( i ), ig ( i ), ierr ) enddo end function ig !=================================================================================================================================== function rg () real , allocatable :: rg (:) rg = real ( dg ()) end function rg !=================================================================================================================================== function dg () real ( kind = dp ), allocatable :: dg (:) integer :: i integer :: ierr if ( allocated ( dg )) deallocate ( dg ) allocate ( dg ( size ( unnamed ))) do i = 1 , size ( dg ) call a2d ( unnamed ( i ), dg ( i ), ierr ) enddo end function dg !=================================================================================================================================== function lg () logical , allocatable :: lg (:) integer :: i integer :: iichar character , allocatable :: hold if ( allocated ( lg )) deallocate ( lg ) allocate ( lg ( size ( unnamed ))) do i = 1 , size ( lg ) hold = trim ( upper ( adjustl ( unnamed ( i )))) if ( hold ( 1 : 1 ) == '.' ) then ! looking for fortran logical syntax .STRING. iichar = 2 else iichar = 1 endif select case ( hold ( iichar : iichar )) ! check word to see if true or false case ( 'T' , 'Y' , ' ' ); lg ( i ) = . true . ! anything starting with \"T\" or \"Y\" or a blank is TRUE (true,yes,...) case ( 'F' , 'N' ); lg ( i ) = . false . ! assume this is false or no case default call journal ( \"*lg* bad logical expression for element\" , i , '=' , hold ) end select enddo end function lg !=================================================================================================================================== function cg () complex , allocatable :: cg (:) integer :: i , ierr real ( kind = dp ) :: rc , ic if ( allocated ( cg )) deallocate ( cg ) allocate ( cg ( size ( unnamed ))) do i = 1 , size ( cg ), 2 call a2d ( unnamed ( i ), rc , ierr ) call a2d ( unnamed ( i + 1 ), ic , ierr ) cg ( i ) = cmplx ( rc , ic , kind = sp ) enddo end function cg !=================================================================================================================================== ! Does not work with gcc 5.3 !function sg() !character(len=:),allocatable :: sg(:) ! sg=unnamed !end function sg !=================================================================================================================================== function sg () character ( len = :), allocatable :: sg (:) if ( allocated ( sg )) deallocate ( sg ) allocate ( sg , source = unnamed ) end function sg !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine mystop ( sig , msg ) ! negative signal means always stop program ! else do not stop and set G_STOP_MESSAGE if G_QUIET is true ! or ! print message and stop if G_QUIET is false ! the MSG is NOT for displaying except for internal errors when the program will be stopped. ! It is for returning a value when the stop is being ignored ! integer , intent ( in ) :: sig character ( len =* ), intent ( in ), optional :: msg if ( sig < 0 ) then if ( present ( msg )) call journal ( msg ) stop 1 elseif (. not . G_QUIET ) then stop else if ( present ( msg )) then G_STOP_MESSAGE = msg else G_STOP_MESSAGE = '' endif G_STOP = sig endif end subroutine mystop !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== function atleast ( line , length , pattern ) result ( strout ) ! ident_30=\"@(#) M_strings atleast(3f) return string padded to at least specified length\" character ( len =* ), intent ( in ) :: line integer , intent ( in ) :: length character ( len =* ), intent ( in ), optional :: pattern character ( len = max ( length , len ( trim ( line )))) :: strout if ( present ( pattern )) then strout = line // repeat ( pattern , len ( strout ) / len ( pattern ) + 1 ) else strout = line endif end function atleast !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= !=================================================================================================================================== subroutine locate_key ( value , place ) ! ident_31=\"@(#) M_CLI2 locate_key(3f) find PLACE in sorted character array where VALUE can be found or should be placed\" character ( len =* ), intent ( in ) :: value integer , intent ( out ) :: place integer :: ii character ( len = :), allocatable :: value_local if ( G_UNDERDASH ) then value_local = trim ( replace_str ( value , '-' , '_' )) else value_local = trim ( value ) endif if ( G_NOSEPARATOR ) then value_local = replace_str ( value_local , '-' , '' ) value_local = replace_str ( value_local , '_' , '' ) endif if ( G_IGNORECASE . and . len_trim ( value_local ) > 1 ) value_local = lower ( value_local ) if ( len ( value_local ) == 1 ) then !x!ii=findloc(shorts,value_local,dim=1) ii = maxloc ([ 0 , merge ( 1 , 0 , shorts == value_local )], dim = 1 ) if ( ii > 1 ) then place = ii - 1 else call locate_ ( keywords , value_local , place ) endif else call locate_ ( keywords , value_local , place ) endif end subroutine locate_key !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== !> !!##NAME !! set_mode(3f) - [ARGUMENTS:M_CLI2] turn on optional modes !! (LICENSE:PD) !! !!##SYNOPSIS !! !! subroutine set_mode(key,mode) !! !! character(len=*),intent(in) :: key !! logical,intent(in),optional :: mode !! !!##DESCRIPTION !! Allow optional behaviors. !! !!##OPTIONS !! KEY name of option !! !! The following values are allowed: !! !! o response_file - enable use of response file !! !! o ignorecase - ignore case in long key names. So the user !! does not have to remember if the option is --IgnoreCase !! or --ignorecase or --ignoreCase !! !! o underdash - treat dash in keyword as an underscore. !! So the user should not have to remember if the option is !! --ignore_case or --ignore-case. !! !! o strict - allow Boolean keys to be bundled, but requires !! a single dash prefix be used for short key names and !! long names must be prefixed with two dashes. !! !! o lastonly - when multiple keywords occur keep the rightmost !! value specified instead of appending the values together. !! !! MODE set to .true. to activate the optional mode. !! Set to .false. to deactivate the mode. !! It is .true. by default. !! !!##EXAMPLE !! !! Sample program: !! !! program demo_set_mode !! use M_CLI2, only : set_args, lget, set_mode !! implicit none !! character(len=*),parameter :: all='(*(g0))' !! ! !! ! enable use of response files !! call set_mode('response_file') !! ! !! ! Any dash in a keyword is treated as an underscore !! call set_mode('underdash') !! ! !! ! The case of long keywords are ignored. !! ! Values and short names remain case-sensitive !! call set_mode('ignorecase') !! ! !! ! short single-character boolean keys may be bundled !! ! but it is required that a single dash is used for !! ! short keys and a double dash for long keywords. !! call set_mode('strict') !! ! !! call set_args(' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F') !! ! !! print all,'--switch_X or -X ... ',lget('switch_X') !! print all,'--switch_Y or -Y ... ',lget('switch_Y') !! print all,'--ox or -O ... ',lget('ox') !! print all,'-o ... ',lget('o') !! print all,'-x ... ',lget('x') !! print all,'-t ... ',lget('t') !! end program demo_set_mode !! !!##AUTHOR !! John S. Urban, 2019 !!##LICENSE !! Public Domain !=================================================================================================================================== elemental impure subroutine set_mode ( key , mode ) character ( len =* ), intent ( in ) :: key logical , intent ( in ), optional :: mode logical :: local_mode if ( present ( mode )) then local_mode = mode else local_mode = . true . endif select case ( lower ( key )) case ( 'response_file' , 'response file' ); CLI_RESPONSE_FILE = local_mode case ( 'debug' ); G_DEBUG = local_mode case ( 'ignorecase' ); G_IGNORECASE = local_mode case ( 'underdash' ); G_UNDERDASH = local_mode case ( 'noseparator' ); G_NOSEPARATOR = local_mode case ( 'strict' ); G_STRICT = local_mode case ( 'lastonly' ); G_APPEND = . not . local_mode case default call journal ( '*set_mode* unknown key name ' , key ) end select if ( G_DEBUG ) write ( * , gen ) 'EXPAND_RESPONSE:END' end subroutine set_mode !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !=================================================================================================================================== end module M_CLI2 !=================================================================================================================================== !()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! !===================================================================================================================================","tags":"","loc":"sourcefile/m_cli2.f90.html"},{"title":"hello.f90 – M_CLI2","text":"Contents Programs demo3 Source Code hello.f90 Source Code program demo3 !! example of **basic** use !*! JUST THE BARE ESSENTIALS use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title call set_args ( '-x 1 -y 10 --size:s 12.34567 -l F --title:t \"my title\"' ) call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! all variables set and of the right type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"sourcefile/hello.f90.html"},{"title":"xx.f90 – M_CLI2","text":"Contents Programs minimal Source Code xx.f90 Source Code program minimal use M_CLI2 , only : set_args , lget , rget , sgets , igets , set_mode implicit none real :: x , y integer :: i integer , allocatable :: ints (:) character ( len = :), allocatable :: filenames (:) ! define and crack command line !call set_mode('debug') call set_args ( ' --yvalue:y 0.0 --xvalue:x 0.0 --ints [] --debug F' ) ! get values write ( * , * ) 'INTS=' , igets ( 'ints' ) x = rget ( 'xvalue' ) y = rget ( 'yvalue' ) if ( lget ( 'debug' )) then write ( * , * ) 'X=' , x write ( * , * ) 'Y=' , y write ( * , * ) 'ATAN2(Y,X)=' , atan2 ( x = x , y = y ) else write ( * , * ) atan2 ( x = x , y = y ) end if filenames = sgets () ! sget with no name gets \"unnamed\" values if ( size ( filenames ) > 0 ) then write ( * , '(g0)' ) 'filenames:' write ( * , '(i6.6,3a)' ) ( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) end if end program minimal","tags":"","loc":"sourcefile/xx.f90.html"},{"title":"demo2.f90 – M_CLI2","text":"Contents Programs demo2 Source Code demo2.f90 Source Code program demo2 !! @(#) all parsing and **help** and **version** information in a contained procedure. use M_CLI2 , only : unnamed implicit none integer :: i !! DEFINE \"ARGS\" VALUES integer :: x , y , z real :: point ( 3 ) character ( len = 80 ) :: title logical :: l , l_ print * , 'demo2: all parsing and **help** and **version** information in a contained procedure' call parse () !! DEFINE AND PARSE COMMAND LINE !! ALL DONE CRACKING THE COMMAND LINE USE THE VALUES IN YOUR PROGRAM. write ( * , * ) x + y + z write ( * , * ) point * 2 write ( * , * ) title write ( * , * ) l , l_ !! THE OPTIONAL UNNAMED VALUES ON THE COMMAND LINE ARE !! ACCUMULATED IN THE CHARACTER ARRAY \"UNNAMED\" if ( size ( unnamed ) > 0 ) then write ( * , '(a)' ) 'files:' write ( * , '(i6.6,3a)' )( i , '[' , unnamed ( i ), ']' , i = 1 , size ( unnamed )) endif contains subroutine parse () !! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length character ( len = :), allocatable :: help_text (:), version_text (:) !! DEFINE COMMAND PROTOTYPE !! o All parameters must be listed with a default value !! o string values must be double-quoted !! o numeric lists must be comma-delimited. No spaces are allowed !! o long keynames must be all lowercase character ( len =* ), parameter :: cmd = '& & -x 1 -y 2 -z 3 & & --point -1,-2,-3 & & --title \"my title\" & & -l F -L F & & ' help_text = [ character ( len = 80 ) :: & 'NAME ' , & ' myprocedure(1) - make all things possible ' , & 'SYNOPSIS ' , & ' function myprocedure(stuff) ' , & ' class(*) :: stuff ' , & 'DESCRIPTION ' , & ' myprocedure(1) makes all things possible given STUFF ' , & 'OPTIONS ' , & ' STUFF things to do things to ' , & 'RETURNS ' , & ' MYPROCEDURE the answers you want ' , & 'EXAMPLE ' , & '' ] version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo2 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] call set_args ( cmd , help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'point' , point ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) end subroutine parse end program demo2","tags":"","loc":"sourcefile/demo2.f90.html"},{"title":"demo12.f90 – M_CLI2","text":"Contents Programs demo12 Source Code demo12.f90 Source Code program demo12 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , rget implicit none real :: x , y , z print * , 'demo12: using the convenience functions' !! ENABLE USING RESPONSE FILES call set_mode ( 'response file' ) call set_args ( '-x 1.1 -y 2e3 -z -3.9 ' ) x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z end program demo12","tags":"","loc":"sourcefile/demo12.f90.html"},{"title":"demo3.f90 – M_CLI2","text":"Contents Programs demo3 Source Code demo3.f90 Source Code program demo3 !! @(#) example of **basic** use using just the bare essentials use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = :), allocatable :: title print * , 'demo3: just the bare essentials' ! define the command, set default values and read the command line call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! get the values call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size ) ! all the non-allocatables call get_args ( 'title' , title ) ! do allocatables one at a time ! Done. All variables set and of the requested type write ( * , '(*(\"[\",g0,\"]\":,1x))' ) x , y , size , l , title end program demo3","tags":"","loc":"sourcefile/demo3.f90.html"},{"title":"demo17.f90 – M_CLI2","text":"Contents Programs demo17 Source Code demo17.f90 Source Code program demo17 !! @(#) using the unnamed parameters as filenames !! For example, this should list the files in the current directory !! !! demo17 * !! !! Also demonstrates setting --help and --version text. !! !! demo17 --help !! demo17 --version !! demo17 --usage !! use M_CLI2 , only : get_args use M_CLI2 , only : sget , lget , iget , rget , dget , cget use M_CLI2 , only : sgets , lgets , igets , rgets , dgets , cgets use M_CLI2 , only : filenames => unnamed implicit none type ( character ( len =* )), parameter :: all = '(*(g0))' type ( integer ) :: indx !! argument values to set type ( integer ) :: i , j , k type ( real ) :: x , y , z type ( character ( len = :)), allocatable :: title type ( logical ) :: l , m , n type ( character ( len = :)), allocatable :: fnames (:) print all , 'demo17: using the unnamed parameters as filenames' print all , 'example: demo17 -x 100 * ' call parse () !! Define and parse command line !! Get argument values call get_args ( 'x' , x , 'y' , y , 'z' , z ) call get_args ( 'i' , i , 'j' , j , 'k' , k ) call get_args ( 'l' , l , 'm' , m , 'n' , n ) title = sget ( 'title' ) !! All done cracking the command line use the values in your program. print all , 'x=' , x , ' y=' , y , ' z=' , z print all , 'i=' , i , ' j=' , j , ' k=' , k print all , 'l=' , l , ' m=' , m , ' n=' , n print all , 'title=' , title !! The optional unnamed values on the command line are !! accumulated in the character array \"UNNAMED\" which was !! renamed to \"FILENAMES\" on the use statement if ( allocated ( filenames )) then if ( size ( filenames ) > 0 ) then print all , 'files:' print '(i6.6,1x,3a)' ,( indx , '[' , filenames ( indx ), ']' , indx = 1 , size ( filenames )) endif endif ! alternate method, additionally can be used when desired result is numeric ! by using igets(3f), rgets(3f), ... instead of sgets(3f). fnames = sgets () ! also gets all the unnamed arguments if ( size ( fnames ) > 0 ) then print all , 'files:' print '(i6.6,1x,3a)' ,( indx , '[' , fnames ( indx ), ']' , indx = 1 , size ( fnames )) endif contains subroutine parse () !! Put everything to do with command parsing here !! use M_CLI2 , only : set_args , set_mode call set_mode ([ character ( len = 20 ) :: 'strict' , 'ignorecase' ]) ! a single call to set_args can define the options and their defaults, set help ! text and version information, and crack command line. call set_args (& !! DEFINE COMMAND OPTIONS AND DEFAULT VALUES ' & -i 1 -j 2 -k 3 & -l F -m F -n F & -x 1 -y 2 -z 3 & --title \"my title\" & !! ## HELP TEXT ## ' , [ character ( len = 80 ) :: & !12345678901234567890123456789012345678901234567890123456789012345678901234567890 'NAME ' , & ' myprogram(1) - make all things possible ' , & 'SYNOPSIS ' , & ' myprogram [-i NNN] [-j NNN] [-k NNN] [-l] [-m] [-n] ] ' , & ' [-x NNN.mm] [-y NNN.mm] [-z NNN.mm] [FILENAMES] ' , & 'DESCRIPTION ' , & ' myprogram(1) makes all things possible given stuff. ' , & 'OPTIONS ' , & ' -i,-j,-k some integer values ' , & ' -l,-m,-n some logical values ' , & ' -x,-y,-z some real values ' , & ' --title a string argument ' , & ' FILENAMES any additional strings ' , & 'EXAMPLE ' , & ' Typical usage: ' , & ' ' , & ' demo17 *.* ' , & ' ' , & ' ' , & !! ## VERSION TEXT (with optional @(#) prefix for what(1) command) ## '' ], [ character ( len = 80 ) :: & '@(#)PROGRAM: demo17 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200115 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ]) end subroutine parse end program demo17","tags":"","loc":"sourcefile/demo17.f90.html"},{"title":"demo9.f90 – M_CLI2","text":"Contents Programs demo9 Source Code demo9.f90 Source Code program demo9 !> @(#) long and short names using --LONGNAME:SHORTNAME !! !! When all keys have a long and short name and \"strict mode\" is invoked !! where \"-\" is required for short names and \"--\" for long names Boolean !! values may be bundled together. For example: !! !! demo9 -XYZ !! use M_CLI2 , only : set_args , sget , rget , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo9: long and short names using --LONGNAME:SHORTNAME' !call set_mode('strict') call set_args ( ' & & --length:l 10 & & --height:h 12.45 & & --switchX:X F & & --switchY:Y F & & --switchZ:Z F & & --title:T \"my title\"' ) print all , '--length or -l .... ' , rget ( 'length' ) print all , '--height or -h .... ' , rget ( 'height' ) print all , '--switchX or -X ... ' , lget ( 'switchX' ) print all , '--switchY or -Y ... ' , lget ( 'switchY' ) print all , '--switchZ or -Z ... ' , lget ( 'switchZ' ) print all , '--title or -T ..... ' , sget ( 'title' ) end program demo9","tags":"","loc":"sourcefile/demo9.f90.html"},{"title":"demo15.f90 – M_CLI2","text":"Contents Programs demo15 Source Code demo15.f90 Source Code program demo15 !> @(#) strict mode !! !! In strict mode short single-character names may be bundled but it is !! required that a single dash is used, where normally single and double !! dashes are equivalent. !! !! demo15 -o -t -x !! demo15 -otx !! demo15 -xto !! !! Only Boolean keynames may be bundled together !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo15: strict mode' call set_mode ( 'strict' ) call set_args ( ' -o F -t F -x F --ox F' ) print all , 'o=' , lget ( 'o' ), ' t=' , lget ( 't' ), ' x=' , lget ( 'x' ), ' ox=' , lget ( 'ox' ) end program demo15","tags":"","loc":"sourcefile/demo15.f90.html"},{"title":"demo6.f90 – M_CLI2","text":"Contents Programs demo6 Source Code demo6.f90 Source Code program demo6 !! @(#) SUBCOMMANDS !! !! For a command with subcommands like git(1) you can call this program !! which has two subcommands (run, test), like this: !! !! demo6 --help !! demo6 run -x -y -z -title -l -L !! demo6 test -title -l -L -testname !! demo6 run --help !! use M_CLI2 , only : set_args , get_args , get_args_fixed_length , get_subcommand use M_CLI2 , only : rget , sget , lget use M_CLI2 , only : CLI_RESPONSE_FILE implicit none character ( len = :), allocatable :: name ! the subcommand name character ( len = :), allocatable :: version_text (:), help_text (:) ! define some values to use as arguments character ( len = 80 ) :: title , testname logical :: l , l_ print * , 'demo6: creating subcommands' version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo6 >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] CLI_RESPONSE_FILE = . true . ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () ! define commands and parse command line and set help text and process command select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' , help_text , version_text ) ! example using convenience functions to retrieve values and pass them ! to a routine call my_run ( rget ( 'x' ), rget ( 'y' ), rget ( 'z' ), sget ( 'title' ), lget ( 'l' ), lget ( 'L' )) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args ( '--title \"my title\" -l F -L F --testname \"Test\"' , help_text , version_text ) ! use get_args(3f) to extract values and use them call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) ! all done cracking the command line. use the values in your program. write ( * , * ) 'command was ' , name write ( * , * ) 'title .... ' , trim ( title ) write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , trim ( testname ) case ( '' ) ! general help for \"demo6 --help\" help_text = [ character ( len = 80 ) :: & ' General help describing the ' , & ' program. ' , & '' ] call set_args ( ' ' , help_text , version_text ) ! process help and version case default call set_args ( ' ' , help_text , version_text ) ! process help and version write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' end select contains subroutine my_run ( x , y , z , title , l , l_ ) ! nothing about commandline parsing here! real , intent ( in ) :: x , y , z character ( len =* ), intent ( in ) :: title logical , intent ( in ) :: l logical , intent ( in ) :: l_ write ( * , * ) 'MY_RUN' write ( * , * ) 'x,y,z .....' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ end subroutine my_run end program demo6","tags":"","loc":"sourcefile/demo6.f90.html"},{"title":"demo5.f90 – M_CLI2","text":"Contents Programs demo5 Source Code demo5.f90 Source Code program demo5 !! @(#) _CHARACTER_ type values !! character variables have a length, unlike number variables use M_CLI2 , only : set_args , get_args use M_CLI2 , only : get_args_fixed_size , get_args_fixed_length use M_CLI2 , only : sget , sgets implicit none character ( len =* ), parameter :: fmt = '(*(\"[\",g0,\"]\":,1x))' print * , 'demo5: CHARACTER argument examples' call set_args ( ' & & --alloc_len_scalar \" \" & & --fx_len_scalar \" \" & & --alloc_array \"A,B,C\" & & --fx_size_fx_len \"A,B,C\" & & --fx_len_alloc_array \"A,B,C\" & & ' ) block ! you just need get_args(3f) for general scalars or arrays ! variable length scalar character ( len = :), allocatable :: alloc_len_scalar ! variable array size and variable length character ( len = :), allocatable :: alloc_array (:) call get_args ( 'alloc_len_scalar' , alloc_len_scalar ) write ( * , fmt ) 'allocatable length scalar=' , alloc_len_scalar ,& & len ( alloc_len_scalar ) call get_args ( 'alloc_array' , alloc_array ) write ( * , fmt ) 'allocatable array= ' , alloc_array endblock ! less commonly, if length or size is fixed, use a special function block character ( len = 19 ), allocatable :: fx_len_alloc_array (:) call get_args_fixed_length ( 'fx_len_alloc_array' , fx_len_alloc_array ) write ( * , fmt ) 'fixed length allocatable array=' , fx_len_alloc_array endblock block character ( len = 19 ) :: fx_len_scalar call get_args_fixed_length ( 'fx_len_scalar' , fx_len_scalar ) write ( * , fmt ) 'fixed length scalar= ' , fx_len_scalar endblock block character ( len = 19 ) :: fx_size_fx_len ( 3 ) call get_args_fixed_size ( 'fx_size_fx_len' , fx_size_fx_len ) write ( * , fmt ) 'fixed size fixed length= ' , fx_size_fx_len endblock block ! or (recommended) set to an allocatable array and check size and ! length returned character ( len = :), allocatable :: a ! variable length scalar character ( len = :), allocatable :: arr (:) ! variable array size and variable length call get_args ( 'fx_size_fx_len' , arr ) ! or arr = sgets ( 'fx_size_fx_len' ) if ( size ( arr ) /= 3 ) write ( * , * ) 'not right size' if ( len ( arr ) > 19 ) write ( * , * ) 'longer than wanted' call get_args ( 'fx_len_scalar' , a ) !or a = sget ( 'fx_len_scalar' ) if ( len ( a ) > 19 ) write ( * , * ) 'too long' write ( * , * ) a , len ( a ) write ( * , * ) arr , len ( arr ), size ( arr ) endblock end program demo5","tags":"","loc":"sourcefile/demo5.f90.html"},{"title":"demo7.f90 – M_CLI2","text":"Contents Programs demo7 Source Code demo7.f90 Source Code program demo7 !! @(#) controlling array delimiter characters use M_CLI2 , only : set_args , get_args , get_args_fixed_size , get_args_fixed_length implicit none integer , parameter :: dp = kind ( 0.0d0 ) character ( len = 20 ), allocatable :: flen (:) ! allocatable array with fixed length character ( len = 4 ) :: fixed ( 2 ) ! fixed-size array wih fixed length integer , allocatable :: integers (:) real , allocatable :: reals (:) real ( kind = dp ), allocatable :: doubles (:) real ( kind = dp ), allocatable :: normal (:) complex , allocatable :: complexs (:) character ( len = :), allocatable :: characters (:) ! allocatable array with allocatable length print * , 'demo7: controlling array delimiter characters' ! ARRAY DELIMITERS ! ! NOTE SET_ARGS(3f) DELIMITERS MUST MATCH WHAT IS USED IN GET_ARGS*(3f) ! call set_args ( '-flen A,B,C -fixed X,Y --integers z --reals 111/222/333 -normal , --doubles | --complexs 0!0 --characters @' ) call get_args ( 'integers' , integers , delimiters = 'abcdefghijklmnopqrstuvwxyz' ) call get_args ( 'reals' , reals , delimiters = '/' ) call get_args ( 'doubles' , doubles , delimiters = '|' ) call get_args ( 'complexs' , complexs , delimiters = '!' ) call get_args ( 'normal' , normal ) call get_args ( 'characters' , characters , delimiters = '@' ) call get_args_fixed_length ( 'flen' , flen ) call get_args_fixed_size ( 'fixed' , fixed ) ! fixed length and fixed size array write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( flen ), 'flen=' , flen write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( characters ), 'characters=' , characters write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( integers ), 'integers=' , integers write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( reals ), 'reals=' , reals write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( doubles ), 'doubles=' , doubles write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( complexs ), 'complexs=' , complexs write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( normal ), 'normal=' , normal write ( * , '(g0,1x,a,*(\"[\",g0,\"]\":,1x))' ) size ( fixed ), 'fixed=' , fixed end program demo7 !================================================================================================================================== ! EXAMPLE CALL ! demo7 -integers 1a2b3c4d5e6 -reals 1/2/3/4 -doubles '40|50|60' -complexs '2!3!4!5' --characters aaa@BBBB@c,d,e ! EXPECTED OUTPUT ! 3 characters=[aaa ] [BBBB ] [c,d,e] ! 6 integers=[1] [2] [3] [4] [5] [6] ! 4 reals=[1.00000000] [2.00000000] [3.00000000] [4.00000000] ! 3 doubles=[40.000000000000000] [50.000000000000000] [60.000000000000000] ! 0 normal=[ ! 2 complexs=[2.00000000] [3.00000000] [4.00000000] [5.00000000] ! 2 fixed=[X ] [Y ] !==================================================================================================================================","tags":"","loc":"sourcefile/demo7.f90.html"},{"title":"demo11.f90 – M_CLI2","text":"Contents Programs demo11 Source Code demo11.f90 Source Code program demo11 !! @(#) examples of validating values with ALL(3f) and ANY(3f) use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT implicit none type point integer :: x = 0 integer :: y = 0 character ( len = 20 ) :: color = 'red' endtype point type ( point ) :: dot ; namelist / nml_dot / dot character ( len = :), allocatable :: name character ( len = :), allocatable :: string character ( len = :), allocatable :: list (:) character ( len = 80 ) :: readme !(3) integer :: i print * , 'demo11: examples of validating values with ALL(3f) and ANY(3f)' ! M_CLI2 intentionally does not have complex validators except for SPECIFIED(3f) and ! a check whether the input conforms to the type with get_args(3f) ! or the convenience functions like inum(3f). ! ! Fortran already has powerful validation capabilities. Logical ! expressions ANY(3f) and ALL(3f) are standard Fortran features easily ! allow performing the common validations for command line arguments ! without having to learn any additional syntax or methods. do i = 1 , 100 if ( all ([ i >= 10 , i <= 30 ,( i / 2 ) * 2 == i ])) then write ( * , * ) i , ' is an even number from 10 to 30 inclusive' endif enddo name = 'red' list = [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ] if ( any ( name == list ) ) then write ( * , * ) name , ' matches a value in the list' else write ( * , * ) name , ' not in the list' endif if ( size ( list ). eq . 3 ) then write ( * , * ) ' list has expected number of values' else write ( * , * ) ' list does not have expected number of values' endif ! and even user-defined types can be processed by reading the input ! as a string and using a NAMELIST(3f) group to convert it. Note that ! if input values are strings that have to be quoted (ie. more than one ! word) or contain characters special to the shell that how you have to ! quote the command line can get complicated. string = '10,20,\"green\"' readme = '&nml_dot dot=' // string // '/' ! some compilers might require the input to be on three lines !readme=[ character(len=80) ::& !'&nml_dot', & !'dot='//string//' ,', & !'/'] read ( readme , nml = nml_dot ) write ( * , * ) dot % x , dot % y , dot % color ! or write ( * , nml_dot ) ! Hopefully it is obvious how the options can be read from values gotten ! with SGET(3f) and SGETS(3f) in this case, and with functions like IGET(3f) ! in the first case, so this example just uses simple declarations to highlight ! some useful Fortran expressions that can be useful for validating the input ! or even reading user-defined types or even intrinsics via NAMELIST(7f) groups. ! another alternative would be to validate expressions from strings using M_calculator(3f) ! but I find it easier to validate the values using regular Fortran code than doing it ! via M_CLI2(3f), although if TLI (terminal screen GUIs) or GUIs are supported later by ! M_CLI2(3f) doing validation in the input forms themselves would be more desirable. end program demo11","tags":"","loc":"sourcefile/demo11.f90.html"},{"title":"demo1.f90 – M_CLI2","text":"Contents Programs demo1 Source Code demo1.f90 Source Code program demo1 !! @(#) using the convenience functions use M_CLI2 , only : set_args , get_args_fixed_size , set_mode use M_CLI2 , only : dget , iget , lget , rget , sget , cget ! for scalars use M_CLI2 , only : dgets , igets , lgets , rgets , sgets , cgets ! for allocatable arrays implicit none !! DECLARE \"ARGS\" real :: x , y , z , point ( 3 ) character ( len = :), allocatable :: title , anytitle logical :: l , lupper print * , 'demo1: using the convenience functions' call set_mode ( 'response_file' ) !! SET ALL ARGUMENTS TO DEFAULTS WITH SHORT NAMES FOR LONG NAMES AND THEN ADD COMMAND LINE VALUES call set_args ( '-x 1.1 -y 2e3 -z -3.9 --point:p -1,-2,-3 --title:T \"my title\" --anytitle:a \"my title\" -l F -L F' ) !! ALL DONE CRACKING THE COMMAND LINE. GET THE VALUES x = rget ( 'x' ) y = rget ( 'y' ) z = rget ( 'z' ) l = lget ( 'l' ) lupper = lget ( 'L' ) title = sget ( 'title' ) anytitle = sget ( 'anytitle' ) ! With a fixed-size array to ensure the correct number of values are input use call get_args_fixed_size ( 'point' , point ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'y=' , y , 'z=' , z , 'SUM=' , x + y + z , ' point=' , point write ( * , '(*(g0:,1x))' ) 'title=' , trim ( title ), ' l=' , l , 'L=' , lupper write ( * , '(*(g0:,1x))' ) 'anytitle=' , trim ( anytitle ) end program demo1 !! NOTES: WHEN DEFINING THE PROTOTYPE ! o All parameters must be listed with a default value ! o string values must be double-quoted ! o numeric lists must be comma-delimited. No spaces are allowed ! o long keynames must be all lowercase but may be followed by :LETTER where LETTER is a ! single letter that may be of any case that will act as a short name for the same value.","tags":"","loc":"sourcefile/demo1.f90.html"},{"title":"demo4.f90 – M_CLI2","text":"Contents Programs demo4 Source Code demo4.f90 Source Code program demo4 !! @(#) _COMPLEX_ type values use M_CLI2 , only : set_args , get_args , get_args_fixed_size implicit none complex :: x , y , z ! scalars complex , allocatable :: aarr (:) ! allocatable array complex :: three ( 3 ) ! fixed-size array ! formats to pretty-print a complex value and small complex vector character ( len =* ), parameter :: form = '(\"(\",g0,\",\",g0,\"i)\":,1x)' character ( len =* ), parameter :: forms = '(*(\"(\",g0,\",\",g0,\"i)\":,\",\",1x))' print * , 'demo4: COMPLEX argument example' ! COMPLEX VALUES ! ! o parenthesis are optional and are ignored in complex values. ! ! o base#value is acceptable for base 2 to 32 for whole numbers, ! which is why \"i\" is not allowed as a suffix on imaginary values ! (because some bases include \"i\" as a digit). ! ! o normally arrays are allocatable. if a fixed size array is used ! call get_args_fixed_size(3f) and all the values must be ! specified. This is useful when you have something that requires ! a specific number of values. Perhaps a point in space must always ! have three values, for example. ! ! o default delimiters are whitespace, comma and colon. Note that ! whitespace delimiters should not be used in the definition, ! but are OK on command input if the entire parameter value is ! quoted. Using space delimiters in the prototype definition is ! not supported (but works) and requires that the value be quoted ! on input in common shells. Adjacent delimiters are treated as ! a single delimiter. ! call set_args ( '-x (1,2) -y 10,20 -z (2#111,16#-AB) -three 1,2,3,4,5,6 -aarr 111::222,333::444' ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_size ( 'three' , three ) call get_args ( 'aarr' , aarr ) write ( * , form ) x , y , z , x + y + z write ( * , forms ) three write ( * , forms ) aarr end program demo4 ! ! expected output: ! ! (1.00000000,2.00000000i) ! (10.0000000,20.0000000i) ! (7.00000000,-171.000000i) ! (18.0000000,-149.000000i) ! (1.00000000,2.00000000i), (3.00000000,4.00000000i), (5.00000000,6.00000000i) ! (111.000000,222.000000i), (333.000000,444.000000i)","tags":"","loc":"sourcefile/demo4.f90.html"},{"title":"demo16.f90 – M_CLI2","text":"Contents Programs demo16 Source Code demo16.f90 Source Code program demo16 !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets implicit none character ( len =* ), parameter :: all = '(1x,*(g0,1x))' call set_args ( '-type test' ) select case ( sget ( 'type' )) case ( 'i' , 'int' , 'integer' ); print all , igets () case ( 'r' , 'real' ); print all , rgets () case ( 'd' , 'double' ); print all , dgets () case ( 'test' ) print * , 'demo16: convert all arguments to numerics' ! positive BOZ whole number values are allowed ! e-format is allowed, ints(3f) truncates call runit ( '-type i 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) call runit ( '-type r 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) call runit ( '-type d 10 b10 o10 z10 14.1 14.5 14.999 45.67e3' ) case default print all , 'unknown type' end select contains subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program demo16","tags":"","loc":"sourcefile/demo16.f90.html"},{"title":"demo8.f90 – M_CLI2","text":"Contents Programs demo8 Source Code demo8.f90 Source Code program demo8 !! @(#) Sometimes you can put multiple values on getargs(3f) use M_CLI2 , only : set_args , get_args implicit none integer :: x , y logical :: l real :: size character ( len = 80 ) :: title character ( len =* ), parameter :: pairs = '(1(\"[\",g0,\"=\",g0,\"]\":,1x))' print * , 'demo8: Sometimes you can put multiple values on getargs(3f)' ! DEFINE COMMAND AND PARSE COMMAND LINE ! set all values, double-quote strings call set_args ( '-x 1 -y 10 --size 12.34567 -l F --title \"my title\"' ) ! GET THE VALUES ! only fixed scalar values (including only character variables that ! are fixed length) may be combined in one GET_ARGS(3f) call call get_args ( 'x' , x , 'y' , y , 'l' , l , 'size' , size , 'title' , title ) ! USE THE VALUES write ( * , fmt = pairs ) 'X' , x , 'Y' , y , 'size' , size , 'L' , l , 'TITLE' , title end program demo8","tags":"","loc":"sourcefile/demo8.f90.html"},{"title":"manually_test_bundling.f90 – M_CLI2","text":"Contents Programs demo18 Source Code manually_test_bundling.f90 Source Code program demo18 !! @(#) using the convenience functions use M_CLI2 , only : set_args , set_mode , get_args implicit none logical :: o , x , t , ox , xo , x_up , o_up , a , b print * , 'demo18: using the bundling option' call set_mode ( 'strict' ) call set_mode ( 'ignorecase' ) call set_args ( '-x F -o F -X F -O F -t F --ox F -xo F -longa:a F -longb:b' ) call get_args ( 'x' , x , 'o' , o , 't' , t , 'xo' , xo , 'ox' , ox , 'X' , x_up , 'O' , o_up ) call get_args ( 'longa' , a , 'longb' , b ) !! USE THE VALUES IN YOUR PROGRAM. write ( * , '(*(g0:,1x))' ) 'x=' , x , 'o=' , o , 't=' , t write ( * , '(*(g0:,1x))' ) 'ox=' , ox , 'xo=' , xo write ( * , '(*(g0:,1x))' ) 'O=' , o_up , 'X=' , x_up write ( * , '(*(g0:,1x))' ) 'longa=' , a , 'longb=' , b end program demo18","tags":"","loc":"sourcefile/manually_test_bundling.f90.html"},{"title":"demo13.f90 – M_CLI2","text":"Contents Programs demo13 Source Code demo13.f90 Source Code program demo13 !> @(#) underdash mode !! Any dash in a key name is treated as an underscore !! when underdash mode is on !! !! demo13 --switch-X !! demo13 --switch_X !! !! are equivalent when this mode is on !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo13: underdash mode' call set_mode ( 'underdash' ) call set_args ( ' --switch_X:X F --switch-Y:Y F ' ) print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) end program demo13","tags":"","loc":"sourcefile/demo13.f90.html"},{"title":"demo14.f90 – M_CLI2","text":"Contents Programs demo14 Source Code demo14.f90 Source Code program demo14 !> @(#) ignorecase mode !! !! long keynames are internally converted to lowercase !! when ignorecase mode is on these are equivalent !! !! demo14 --longName !! demo14 --longname !! demo14 --LongName !! !! Values and short names remain case-sensitive !! use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' print * , 'demo14: ignorecase mode' call set_mode ( 'ignorecase' ) call set_args ( ' --longName:N F ' ) print all , '--longName or -N ... ' , lget ( 'longName' ) end program demo14","tags":"","loc":"sourcefile/demo14.f90.html"},{"title":"demo_get_args_fixed_length.f90 – M_CLI2","text":"Contents Programs demo_get_args_fixed_length Source Code demo_get_args_fixed_length.f90 Source Code program demo_get_args_fixed_length use M_CLI2 , only : set_args , get_args_fixed_length implicit none ! Define args character ( len = 80 ) :: title ! Parse command line call set_args ( ' --title \"my title\" ' ) ! Assign values to variables call get_args_fixed_length ( 'title' , title ) ! Use values write ( * , * ) 'title=' , title end program demo_get_args_fixed_length","tags":"","loc":"sourcefile/demo_get_args_fixed_length.f90.html"},{"title":"demo_get_subcommand.f90 – M_CLI2","text":"Contents Programs demo_get_subcommand Source Code demo_get_subcommand.f90 Source Code program demo_get_subcommand !x! SUBCOMMANDS !x! For a command with subcommands like git(1) !x! you can make separate namelists for each subcommand. !x! You can call this program which has two subcommands (run, test), !x! like this: !x! demo_get_subcommand --help !x! demo_get_subcommand run -x -y -z --title -l -L !x! demo_get_subcommand test --title -l -L --testname !x! demo_get_subcommand run --help implicit none !x! DEFINE VALUES TO USE AS ARGUMENTS WITH INITIAL VALUES real :: x =- 99 9.0 , y =- 99 9.0 , z =- 99 9.0 character ( len = 80 ) :: title = \"not set\" logical :: l = . false . logical :: l_ = . false . character ( len = 80 ) :: testname = \"not set\" character ( len = 20 ) :: name call parse ( name ) !x! DEFINE AND PARSE COMMAND LINE !x! ALL DONE CRACKING THE COMMAND LINE. !x! USE THE VALUES IN YOUR PROGRAM. write ( * , * ) 'command was ' , name write ( * , * ) 'x,y,z .... ' , x , y , z write ( * , * ) 'title .... ' , title write ( * , * ) 'l,l_ ..... ' , l , l_ write ( * , * ) 'testname . ' , testname contains subroutine parse ( name ) !x! PUT EVERYTHING TO DO WITH COMMAND PARSING HERE FOR CLARITY use M_CLI2 , only : set_args , get_args , get_args_fixed_length use M_CLI2 , only : get_subcommand , set_mode character ( len =* ) :: name ! the subcommand name character ( len = :), allocatable :: help_text (:), version_text (:) call set_mode ( 'response_file' ) ! define version text version_text = [ character ( len = 80 ) :: & '@(#)PROGRAM: demo_get_subcommand >' , & '@(#)DESCRIPTION: My demo program >' , & '@(#)VERSION: 1.0 20200715 >' , & '@(#)AUTHOR: me, myself, and I>' , & '@(#)LICENSE: Public Domain >' , & '' ] ! general help for \"demo_get_subcommand --help\" help_text = [ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L --title -x -y -z ' , & ' * test -l -L --title ' , & '' ] ! find the subcommand name by looking for first word on command ! not starting with dash name = get_subcommand () select case ( name ) case ( 'run' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"run\" ' , & ' ' , & '' ] call set_args ( & & '-x 1 -y 2 -z 3 --title \"my title\" -l F -L F' ,& & help_text , version_text ) call get_args ( 'x' , x ) call get_args ( 'y' , y ) call get_args ( 'z' , z ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) case ( 'test' ) help_text = [ character ( len = 80 ) :: & ' ' , & ' Help for subcommand \"test\" ' , & ' ' , & '' ] call set_args (& & '--title \"my title\" -l F -L F --testname \"Test\"' ,& & help_text , version_text ) call get_args_fixed_length ( 'title' , title ) call get_args ( 'l' , l ) call get_args ( 'L' , l_ ) call get_args_fixed_length ( 'testname' , testname ) case default ! process help and version call set_args ( ' ' , help_text , version_text ) write ( * , '(*(a))' ) 'unknown or missing subcommand [' , trim ( name ), ']' write ( * , '(a)' )[ character ( len = 80 ) :: & ' allowed subcommands are ' , & ' * run -l -L -title -x -y -z ' , & ' * test -l -L -title ' , & '' ] stop end select end subroutine parse end program demo_get_subcommand","tags":"","loc":"sourcefile/demo_get_subcommand.f90.html"},{"title":"demo_set_mode.f90 – M_CLI2","text":"Contents Programs demo_set_mode Source Code demo_set_mode.f90 Source Code program demo_set_mode use M_CLI2 , only : set_args , lget , set_mode implicit none character ( len =* ), parameter :: all = '(*(g0))' ! ! enable use of response files call set_mode ( 'response_file' ) ! ! Any dash in a keyword is treated as an underscore call set_mode ( 'underdash' ) ! ! The case of long keywords are ignored. ! Values and short names remain case-sensitive call set_mode ( 'ignorecase' ) ! ! short single-character boolean keys may be bundled ! but it is required that a single dash is used for ! short keys and a double dash for long keywords. call set_mode ( 'strict' ) ! call set_args ( ' --switch_X:X F --switch-Y:Y F --ox:O F -t F -x F -o F' ) ! print all , '--switch_X or -X ... ' , lget ( 'switch_X' ) print all , '--switch_Y or -Y ... ' , lget ( 'switch_Y' ) print all , '--ox or -O ... ' , lget ( 'ox' ) print all , '-o ... ' , lget ( 'o' ) print all , '-x ... ' , lget ( 'x' ) print all , '-t ... ' , lget ( 't' ) end program demo_set_mode","tags":"","loc":"sourcefile/demo_set_mode.f90.html"},{"title":"demo_get_args_fixed_size.f90 – M_CLI2","text":"Contents Programs demo_get_args_fixed_size Source Code demo_get_args_fixed_size.f90 Source Code program demo_get_args_fixed_size use M_CLI2 , only : set_args , get_args_fixed_size implicit none integer , parameter :: dp = kind ( 0.0d0 ) ! DEFINE ARGS real :: x ( 2 ) real ( kind = dp ) :: y ( 2 ) integer :: p ( 3 ) character ( len = 80 ) :: title ( 1 ) logical :: l ( 4 ), lbig ( 4 ) complex :: cmp ( 2 ) ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE ! o only quote strings ! o set all logical values to F or T. call set_args ( ' & & -x 10.0,20.0 & & -y 11.0,22.0 & & -p -1,-2,-3 & & --title \"my title\" & & -l F,T,F,T -L T,F,T,F & & --cmp 111,222.0,333.0e0,4444 & & ' ) ! ASSIGN VALUES TO ELEMENTS call get_args_fixed_size ( 'x' , x ) call get_args_fixed_size ( 'y' , y ) call get_args_fixed_size ( 'p' , p ) call get_args_fixed_size ( 'title' , title ) call get_args_fixed_size ( 'l' , l ) call get_args_fixed_size ( 'L' , lbig ) call get_args_fixed_size ( 'cmp' , cmp ) ! USE VALUES write ( * , * ) 'x=' , x write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig write ( * , * ) 'cmp=' , cmp end program demo_get_args_fixed_size","tags":"","loc":"sourcefile/demo_get_args_fixed_size.f90.html"},{"title":"demo_specified.f90 – M_CLI2","text":"Contents Programs demo_specified Source Code demo_specified.f90 Source Code program demo_specified use , intrinsic :: iso_fortran_env , only : & & stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , igets , rgets , specified , sget , lget implicit none ! Define args integer , allocatable :: ints (:) real , allocatable :: floats (:) logical :: flag character ( len = :), allocatable :: color character ( len = :), allocatable :: list (:) integer :: i call set_args ( '& & --color:c \"red\" & & --flag:f F & & --ints:i 1,10,11 & & --floats:T 12.3, 4.56 & & ' ) ints = igets ( 'ints' ) floats = rgets ( 'floats' ) flag = lget ( 'flag' ) color = sget ( 'color' ) write ( * , * ) 'color=' , color write ( * , * ) 'flag=' , flag write ( * , * ) 'ints=' , ints write ( * , * ) 'floats=' , floats write ( * , * ) 'was -flag specified?' , specified ( 'flag' ) ! elemental write ( * , * ) specified ([ 'floats' , 'ints ' ]) ! If you want to know if groups of parameters were specified use ! ANY(3f) and ALL(3f) write ( * , * ) 'ANY:' , any ( specified ([ 'floats' , 'ints ' ])) write ( * , * ) 'ALL:' , all ( specified ([ 'floats' , 'ints ' ])) ! For mutually exclusive if ( all ( specified ([ 'floats' , 'ints ' ]))) then write ( * , * ) 'You specified both names --ints and --floats' endif ! For required parameter if (. not . any ( specified ([ 'floats' , 'ints ' ]))) then write ( * , * ) 'You must specify --ints or --floats' endif ! check if all values are in range from 10 to 30 and even write ( * , * ) 'are all numbers good?' , all ([ ints >= 10 , ints <= 30 ,( ints / 2 ) * 2 == ints ]) ! perhaps you want to check one value at a time do i = 1 , size ( ints ) write ( * , * ) ints ( i ),[ ints ( i ) >= 10 , ints ( i ) <= 30 ,( ints ( i ) / 2 ) * 2 == ints ( i )] if ( all ([ ints ( i ) >= 10 , ints ( i ) <= 30 ,( ints ( i ) / 2 ) * 2 == ints ( i )]) ) then write ( * , * ) ints ( i ), 'is an even number from 10 to 30 inclusive' else write ( * , * ) ints ( i ), 'is not an even number from 10 to 30 inclusive' endif enddo list = [ character ( len = 10 ) :: 'red' , 'white' , 'blue' ] if ( any ( color == list ) ) then write ( * , * ) color , 'matches a value in the list' else write ( * , * ) color , 'not in the list' endif if ( size ( ints ). eq . 3 ) then write ( * , * ) 'ints(:) has expected number of values' else write ( * , * ) 'ints(:) does not have expected number of values' endif end program demo_specified","tags":"","loc":"sourcefile/demo_specified.f90.html"},{"title":"demo_get_args.f90 – M_CLI2","text":"Contents Programs demo_get_args Source Code demo_get_args.f90 Source Code program demo_get_args use M_CLI2 , only : filenames => unnamed , set_args , get_args implicit none integer :: i ! Define ARGS real :: x , y , z real , allocatable :: p (:) character ( len = :), allocatable :: title logical :: l , lbig ! Define and parse (to set initial values) command line ! o only quote strings and use double-quotes ! o set all logical values to F or T. call set_args ( ' & & -x 1 -y 2 -z 3 & & -p -1,-2,-3 & & --title \"my title\" & & -l F -L F & & --label \" \" & & ' ) ! Assign values to elements ! Scalars call get_args ( 'x' , x , 'y' , y , 'z' , z , 'l' , l , 'L' , lbig ) ! Allocatable string call get_args ( 'title' , title ) ! Allocatable arrays call get_args ( 'p' , p ) ! Use values write ( * , '(1x,g0,\"=\",g0)' ) 'x' , x , 'y' , y , 'z' , z write ( * , * ) 'p=' , p write ( * , * ) 'title=' , title write ( * , * ) 'l=' , l write ( * , * ) 'L=' , lbig if ( size ( filenames ) > 0 ) then write ( * , '(i6.6,3a)' )( i , '[' , filenames ( i ), ']' , i = 1 , size ( filenames )) endif end program demo_get_args","tags":"","loc":"sourcefile/demo_get_args.f90.html"},{"title":"test_syntax.f90 – M_CLI2","text":"Contents Programs test_syntax Source Code test_syntax.f90 Source Code program test_syntax !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , sgets , iget , igets , rget , rgets , dget , dgets , lget , lgets implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' character ( len = :), allocatable :: whichone call set_args ( ' --type run -i 1 --ints:I 1,2,3 -s \" \" --strings \" \" -r 0.0 --reals:R 11.1,22.2,33.3' ) whichone = sget ( 'type' ) select case ( whichone ) case ( 'one' ) call testit ( whichone // ' i' , iget ( 'i' ) == 1 ) call testit ( whichone // ' ints' , all ( igets ( 'ints' ) == [ 1 , 2 , 3 ])) call testit ( whichone // ' r' , rget ( 'r' ) == 0.0 ) call testit ( whichone // ' reals' , all ( rgets ( 'reals' ) == [ 1 1.1 , 2 2.2 , 3 3.3 ])) call testit ( whichone // ' s' , sget ( 's' ) == \" \" ) call testit ( whichone // ' strings' , all ( sgets ( 'strings' ) == [ \" \" ])) case ( 'two' ) call testit ( whichone // ' ints' , all ( igets ( 'ints' ) == [ 0 , 1 , 2 , 20 , 30 , 40 , 300 , 400 , 1000 , 2000 ])) case ( 'three' ) write ( * , it ) 'three:size=' , size ( sgets ( 'strings' )) write ( * , '(*(\"[\",a,\"]\":,1x))' ) sgets ( 'strings' ) case ( 'run' ) print * , 'test_syntax: syntax mode' call runit ( '--type one -u' ) call runit ( '--type one ' ) call runit ( '--type two -I 0,1,2 --ints=20:30:40 --ints 300,400 -I=1000,2000' ) call runit ( '--type three' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test if ( test ) then print it , ':syntax:' , string , 'passed' else print it , ':syntax:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_syntax","tags":"","loc":"sourcefile/test_syntax.f90.html"},{"title":"test_lastonly.f90 – M_CLI2","text":"Contents Programs test_lastonly Source Code test_lastonly.f90 Source Code program test_lastonly !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' logical , parameter :: T = . true ., F = . false . character ( len = :), allocatable :: whichone logical , allocatable :: arr (:) call set_mode ( 'strict' ) call set_mode ( 'lastonly' ) call set_args ( ' --type run -o F -t F -x F --ox F --xo F --longa:O F --longb:X F -a \"aaa\" --stringb:b \"bbb BBB\" -c \"cc c C CC\"' ) whichone = sget ( 'type' ) arr = [ lget ( 'o' ), lget ( 't' ), lget ( 'x' ), lget ( 'ox' ), lget ( 'xo' ), lget ( 'longa' ), lget ( 'longb' )] select case ( whichone ) case ( 'one' ) ; call testit ( whichone ,. not . any ( arr )) case ( 'two' ) ; call testit ( whichone , all ( arr )) case ( 'three' ) ; call testit ( whichone , all ( arr )) case ( 'four' ) ; call testit ( whichone , all ( arr . eqv .[ F , F , F , F , F , T , F ])) case ( 'five' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , T , T ])) case ( 'six' ) ; call testit ( whichone , all ( arr )) case ( 'seven' ) ; print it , 'a=' , sget ( 'a' ); call testit ( whichone , sget ( 'a' ) == 'a b c' ) case ( 'eight' ) ; print it , 'stringb=' , sget ( 'stringb' ); call testit ( whichone , sget ( 'stringb' ) == 'a b c' ) case ( 'nine' ) ; print it , 'stringb=' , sget ( 'stringb' ); call testit ( whichone , sget ( 'stringb' ) == 'a b c' ) case ( 'run' ) print * , 'test_lastonly: lastonly mode' call runit ( '--type one' ) call runit ( '--type two -oxt --ox --xo -OX --longa --longb' ) call runit ( '--type three -t -o -x --ox --xo -O -X --longa --longb' ) call runit ( '--type four --longa --longa --longa --longa' ) call runit ( '--type five -t -o -x --longa --longb -O -X -OX -XO --longb' ) call runit ( '--type six -ox -t --ox --xo --longa --longb -xt -o --ox --xo --longa --longb' ) call runit ( '--type seven -a \"a b c\"' ) call runit ( '--type eight -b \"a b c\"' ) call runit ( '--type nine --stringb \"a b c\"' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':lastonly:' , string , 'passed' else print it , ':lastonly:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_lastonly","tags":"","loc":"sourcefile/test_lastonly.f90.html"},{"title":"test_ignorecase.f90 – M_CLI2","text":"Contents Programs test_ignorecase Source Code test_ignorecase.f90 Source Code program test_ignorecase !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' character ( len = :), allocatable :: whichone character ( len = :), allocatable :: arr (:) call set_mode ( 'ignorecase' ) call set_args ( ' --type run -a \"a AA a\" -b \"B bb B\" -A AAA -B BBB --longa:O \" OoO \" --longb:X \"xXx\"' ) whichone = sget ( 'type' ) arr = [ character ( len = 17 ) :: sget ( 'a' ), sget ( 'b' ), sget ( 'A' ), sget ( 'B' ), sget ( 'longa' ), sget ( 'longb' ), sget ( 'O' ), sget ( 'X' ) ] select case ( whichone ) case ( 'one' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a AA a' , 'B bb B' , 'AAA' , 'BBB' , ' OoO' , 'xXx' , ' OoO' , 'xXx' ] == arr )) case ( 'two' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a' , 'b' , 'A' , 'B' , 'longa O' , 'longb X' , 'longa O' , 'longb X' ] == arr )) case ( 'three' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a' , 'b' , 'A' , 'B' , 'longa O' , 'longb X' , 'longa O' , 'longb X' ] == arr )) case ( 'four' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a A' , 'b B' , 'SET A' , 'SET B' , ' OoO' , 'xXx' , ' OoO' , 'xXx' ] == arr )) case ( 'five' ) ; call testit ( whichone , all ([ character ( len = 17 ) :: 'a AA a' , 'B bb B' , 'AAA' , 'BBB' , & & 'a b c d e f g h i' , 'xXx' , 'a b c d e f g h i' , 'xXx' ] == arr )) case ( 'six' ) ; !call testit(whichone, all(arr)) case ( 'run' ) print * , 'test_ignorecase: ignorecase mode' call runit ( '--type one ' ) call runit ( '--type two -a a -b b -A A -B B -longa longa -longb longb -O O -X X ' ) call runit ( '--type three -a a -b b -A A -B B -LONGA longa -LONGB longb -O O -X X' ) call runit ( '--type four -a a -b b -a A -b B -A \"SET A\" -B \"SET B\"' ) call runit ( '--type five --LongA \"a b c\" -longa \"d e f\" -longA \"g h i\"' ) ! call runit('--type six -ox -t --ox --xo --longa --longb') case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':ignorecase:' , string , 'passed' else print it , ':ignorecase:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_ignorecase","tags":"","loc":"sourcefile/test_ignorecase.f90.html"},{"title":"test_strict.f90 – M_CLI2","text":"Contents Programs test_strict Source Code test_strict.f90 Source Code program test_strict !> @(#) unnamed to numbers !! The default for inums, rnums, ... is to convert all unnamed argument values in \"unnamed\" use , intrinsic :: iso_fortran_env , only : stderr => ERROR_UNIT , stdin => INPUT_UNIT , stdout => OUTPUT_UNIT use M_CLI2 , only : set_args , sget , igets , rgets , dgets , lget , set_mode implicit none character ( len =* ), parameter :: it = '(1x,*(g0,1x))' logical , parameter :: T = . true ., F = . false . character ( len = :), allocatable :: whichone logical , allocatable :: arr (:) call set_mode ( 'strict' ) call set_args ( ' --type run -o F -t F -x F --ox F --xo F --longa:O F --longb:X F' ) whichone = sget ( 'type' ) arr = [ lget ( 'o' ), lget ( 't' ), lget ( 'x' ), lget ( 'ox' ), lget ( 'xo' ), lget ( 'longa' ), lget ( 'longb' )] select case ( whichone ) case ( 'one' ) ; call testit ( whichone ,. not . any ( arr )) case ( 'two' ) ; call testit ( whichone , all ( arr )) case ( 'three' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , F , F ])) case ( 'four' ) ; call testit ( whichone , all ( arr . eqv .[ F , F , F , T , T , F , F ])) case ( 'five' ) ; call testit ( whichone , all ( arr . eqv .[ T , T , T , F , F , F , F ])) case ( 'six' ) ; call testit ( whichone , all ( arr )) case ( 'run' ) print * , 'test_strict: strict mode' call runit ( '--type one ' ) call runit ( '--type two -ox -t --ox --xo -OX' ) call runit ( '--type three -tox ' ) call runit ( '--type four --ox --xo' ) call runit ( '--type five -t -o -x ' ) call runit ( '--type six -ox -t --ox --xo --longa --longb' ) case default print it , 'unknown type' end select contains subroutine testit ( string , test ) character ( len =* ), intent ( in ) :: string logical , intent ( in ) :: test write ( * , it , advance = 'no' ) arr if ( test ) then print it , ':strict:' , string , 'passed' else print it , ':strict:' , string , 'failed' stop 1 endif end subroutine testit subroutine runit ( string ) character ( len =* ), intent ( in ) :: string character ( len = 4096 ) :: cmd call get_command_argument ( 0 , cmd ) write ( stdout , * ) 'RUN:' , trim ( cmd ) // ' ' // string call execute_command_line ( trim ( cmd ) // ' ' // string ) end subroutine runit end program test_strict","tags":"","loc":"sourcefile/test_strict.f90.html"}]}
\ No newline at end of file
diff --git a/docs/fpm-ford/type/point.html b/docs/fpm-ford/type/point.html
index ca499140..f07e4739 100644
--- a/docs/fpm-ford/type/point.html
+++ b/docs/fpm-ford/type/point.html
@@ -128,8 +128,8 @@
Documentation generated by
FORD
- on 2023-02-04 03:16
+ on 2023-02-10 18:53
diff --git a/docs/get_args.3m_cli2.html b/docs/get_args.3m_cli2.html
index 597cea43..38457778 100755
--- a/docs/get_args.3m_cli2.html
+++ b/docs/get_args.3m_cli2.html
@@ -106,9 +106,9 @@
DESCRIPTION
-GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f)
-has been called. For fixed-length CHARACTER variables
-see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has
+been called to parse the command line. For fixed-length CHARACTER
+variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
GET_ARGS_FIXED_SIZE(3f).
As a convenience multiple pairs of keywords and variables may be
@@ -147,7 +147,6 @@
CONVENIENCE FUNCTIONS
-
There are convenience functions that are replacements for calls to
get_args(3f) for each supported default intrinsic type
@@ -188,31 +187,29 @@
EXAMPLE
use M_CLI2, only : filenames=>unnamed, set_args, get_args
implicit none
integer :: i
- ! DEFINE ARGS
+ ! Define ARGS
real :: x, y, z
real,allocatable :: p(:)
character(len=:),allocatable :: title
logical :: l, lbig
- ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
- ! o only quote strings and use double-quotes
- ! o set all logical values to F or T.
- call set_args(’ &
- & -x 1 -y 2 -z 3 &
- & -p -1,-2,-3 &
+ ! Define and parse (to set initial values) command line
+ ! o only quote strings and use double-quotes
+ ! o set all logical values to F or T.
+ call set_args(’ &
+ & -x 1 -y 2 -z 3 &
+ & -p -1,-2,-3 &
& --title "my title" &
- & -l F -L F &
- & --label " " &
+ & -l F -L F &
+ & --label " " &
& ’)
- ! ASSIGN VALUES TO ELEMENTS
- ! SCALARS
- call get_args(’x’,x,’y’,y,’z’,z)
- call get_args(’l’,l)
- call get_args(’L’,lbig)
- ! ALLOCATABLE STRING
+ ! Assign values to elements
+ ! Scalars
+ call get_args(’x’,x,’y’,y,’z’,z,’l’,l,’L’,lbig)
+ ! Allocatable string
call get_args(’title’,title)
- ! NON-ALLOCATABLE ARRAYS
+ ! Allocatable arrays
call get_args(’p’,p)
- ! USE VALUES
+ ! Use values
write(*,’(1x,g0,"=",g0)’)’x’,x, ’y’,y, ’z’,z
write(*,*)’p=’,p
write(*,*)’title=’,title
@@ -241,7 +238,7 @@
LICENSE
Public Domain
-
Nemo Release 3.1
get_args (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from 2bf569ed-7813-45e2-af5b-423d9235bc9f using man macros.
+
Nemo Release 3.1
get_args (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from d07111ae-831f-459b-83a7-5c104f50ca86 using man macros.
+ character(len=*),intent(in) :: name
character(len=:),allocatable :: value
character(len=*),intent(in),optional :: delimiters
@@ -91,7 +92,7 @@
DESCRIPTION
-GET_ARGS_fixed_length(3f) returns the value of a string
+get_args_fixed_length(3f) returns the value of a string
keyword when the string value is a fixed-length CHARACTER
variable.
@@ -131,15 +132,16 @@
EXAMPLE
program demo_get_args_fixed_length
use M_CLI2, only : set_args, get_args_fixed_length
implicit none
- ! DEFINE ARGS
+
+ ! Define args
character(len=80) :: title
- call set_args(’ &
- & --title "my title" &
- & ’)
- ! ASSIGN VALUES TO ELEMENTS
- call get_args_fixed_length(’title’,title)
- ! USE VALUES
- write(*,*)’title=’,title
+ ! Parse command line
+ call set_args(’ --title "my title" ’)
+ ! Assign values to variables
+ call get_args_fixed_length(’title’,title)
+ ! Use values
+ write(*,*)’title=’,title
+
end program demo_get_args_fixed_length
@@ -161,7 +163,7 @@
LICENSE
Public Domain
-
Nemo Release 3.1
get_args_fixed_length (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from 4c561fbb-b7e1-42cc-9f2b-2fba8b46b2cd using man macros.
+
Nemo Release 3.1
get_args_fixed_length (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from 111ba17c-b6b7-48e5-bb54-88a85d129320 using man macros.
+ character(len=*),intent(in) :: name
[real|doubleprecision|integer|logical|complex] :: value(NNN)
or
character(len=MMM) :: value(NNN)
@@ -94,11 +95,16 @@
DESCRIPTION
-GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for
-fixed-size arrays after SET_ARGS(3f) has been called.
-On input on the command line all values of the array must
-be specified.
-
+get_args_fixed_size(3f) returns the value of keywords for fixed-size
+
+
+
+arrays after set_args(3f) has been called.
+On input on the command
+line all values of the array must be specified.
+
+strings must be delimited with double-quotes.
+Since internal double-quotes are represented with two
+double-quotes the string must be at least one space.
+
+
-
-
- + logicals must be set to an unquoted F.
-
- + strings must be delimited with double-quotes.
- Since internal double-quotes are represented with two
- double-quotes the string must be at least one space.
-
-
-
o
@@ -764,7 +767,7 @@
LICENSE
Public Domain
-
Nemo Release 3.1
set_args (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from 79a8a9ed-3edb-4b12-82fc-525c807d2a9d using man macros.
+
Nemo Release 3.1
set_args (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from ba29441f-29e9-4c04-b955-64aa663c4687 using man macros.
Generated by manServer 1.08 from bebb348a-045f-4904-965e-221529161f5f using man macros.
+
Nemo Release 3.1
specified (3m_cli2)
February 10, 2023
Generated by manServer 1.08 from 3c8354e7-128a-40a3-a274-2715e1e6c084 using man macros.
diff --git a/example/demos/demo_M_CLI2.f90 b/example/demos/demo_M_CLI2.f90
index 608dd2c5..234f29c2 100755
--- a/example/demos/demo_M_CLI2.f90
+++ b/example/demos/demo_M_CLI2.f90
@@ -5,8 +5,8 @@ program demo_M_CLI2
implicit none
integer :: i
integer,parameter :: dp=kind(0.0d0)
- !
- ! DEFINE ARGS
+ !
+ ! Define ARGS
real :: x, y, z
logical :: l, lbig
character(len=40) :: label ! FIXED LENGTH
@@ -15,15 +15,15 @@ program demo_M_CLI2
character(len=:),allocatable :: title ! VARIABLE LENGTH
real :: p(3) ! FIXED SIZE
logical :: logi(3) ! FIXED SIZE
- !
- ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
- ! o set a value for all keywords.
- ! o double-quote strings, strings must be at least one space
- ! because adjacent double-quotes designate a double-quote
- ! in the value.
- ! o set all logical values to F
- ! o numeric values support an "e" or "E" exponent
- ! o for lists delimit with a comma, colon, or space
+ !
+ ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+ ! o set a value for all keywords.
+ ! o double-quote strings, strings must be at least one space
+ ! because adjacent double-quotes designate a double-quote
+ ! in the value.
+ ! o set all logical values to F
+ ! o numeric values support an "e" or "E" exponent
+ ! o for lists delimit with a comma, colon, or space
call set_args(' &
& -x 1 -y 2 -z 3 &
& -p -1 -2 -3 &
@@ -34,25 +34,34 @@ program demo_M_CLI2
& --label " " &
! note space between quotes is required
& ')
- ! ASSIGN VALUES TO ELEMENTS
- ! non-allocatable scalars can be done up to twenty per call
+ ! Assign values to elements using G_ARGS(3f).
+ ! non-allocatable scalars can be done up to twenty per call
call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig)
- !
- ! allocatables should be done one at a time
+ ! As a convenience multiple pairs of keywords and variables may be
+ ! specified if and only if all the values are scalars and the CHARACTER
+ ! variables are fixed-length or pre-allocated.
+ !
+ ! After SET_ARGS(3f) has parsed the command line
+ ! GET_ARGS(3f) retrieves the value of keywords accept for
+ ! two special cases. For fixed-length CHARACTER variables
+ ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+ ! GET_ARGS_FIXED_SIZE(3f).
+ !
+ ! allocatables should be done one at a time
call get_args('title',title) ! allocatable string
call get_args('point',point) ! allocatable arrays
call get_args('logicals',logicals)
- !
- ! less commonly ...
+ !
+ ! less commonly ...
- ! for fixed-length strings
+ ! for fixed-length strings
call get_args_fixed_length('label',label)
- ! for non-allocatable arrays
+ ! for non-allocatable arrays
call get_args_fixed_size('p',p)
call get_args_fixed_size('logi',logi)
- !
- ! all done parsing, use values
+ !
+ ! all done parsing, use values
write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z
write(*,*)'p=',p
write(*,*)'point=',point
@@ -62,11 +71,11 @@ program demo_M_CLI2
write(*,*)'L=',lbig
write(*,*)'logicals=',logicals
write(*,*)'logi=',logi
- !
- ! unnamed strings
- !
+ !
+ ! unnamed strings
+ !
if(size(filenames) > 0)then
write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
endif
- !
+ !
end program demo_M_CLI2
diff --git a/example/demos/demo_get_args.f90 b/example/demos/demo_get_args.f90
index 34df95c7..a9bd18df 100755
--- a/example/demos/demo_get_args.f90
+++ b/example/demos/demo_get_args.f90
@@ -2,31 +2,29 @@ program demo_get_args
use M_CLI2, only : filenames=>unnamed, set_args, get_args
implicit none
integer :: i
- ! DEFINE ARGS
+ ! Define ARGS
real :: x, y, z
real,allocatable :: p(:)
character(len=:),allocatable :: title
logical :: l, lbig
- ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
- ! o only quote strings and use double-quotes
- ! o set all logical values to F or T.
- call set_args(' &
- & -x 1 -y 2 -z 3 &
- & -p -1,-2,-3 &
+ ! Define and parse (to set initial values) command line
+ ! o only quote strings and use double-quotes
+ ! o set all logical values to F or T.
+ call set_args(' &
+ & -x 1 -y 2 -z 3 &
+ & -p -1,-2,-3 &
& --title "my title" &
- & -l F -L F &
- & --label " " &
+ & -l F -L F &
+ & --label " " &
& ')
- ! ASSIGN VALUES TO ELEMENTS
- ! SCALARS
- call get_args('x',x,'y',y,'z',z)
- call get_args('l',l)
- call get_args('L',lbig)
- ! ALLOCATABLE STRING
+ ! Assign values to elements
+ ! Scalars
+ call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+ ! Allocatable string
call get_args('title',title)
- ! NON-ALLOCATABLE ARRAYS
+ ! Allocatable arrays
call get_args('p',p)
- ! USE VALUES
+ ! Use values
write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
write(*,*)'p=',p
write(*,*)'title=',title
diff --git a/example/demos/demo_get_args_fixed_length.f90 b/example/demos/demo_get_args_fixed_length.f90
index 9c01781e..34314d51 100755
--- a/example/demos/demo_get_args_fixed_length.f90
+++ b/example/demos/demo_get_args_fixed_length.f90
@@ -1,13 +1,14 @@
program demo_get_args_fixed_length
use M_CLI2, only : set_args, get_args_fixed_length
implicit none
- ! DEFINE ARGS
+
+ ! Define args
character(len=80) :: title
- call set_args(' &
- & --title "my title" &
- & ')
- ! ASSIGN VALUES TO ELEMENTS
- call get_args_fixed_length('title',title)
- ! USE VALUES
- write(*,*)'title=',title
+ ! Parse command line
+ call set_args(' --title "my title" ')
+ ! Assign values to variables
+ call get_args_fixed_length('title',title)
+ ! Use values
+ write(*,*)'title=',title
+
end program demo_get_args_fixed_length
diff --git a/src/M_CLI2.F90 b/src/M_CLI2.F90
index cea39a17..9e6be81e 100755
--- a/src/M_CLI2.F90
+++ b/src/M_CLI2.F90
@@ -84,8 +84,8 @@
!! implicit none
!! integer :: i
!! integer,parameter :: dp=kind(0.0d0)
-!! !
-!! ! DEFINE ARGS
+!! !
+!! ! Define ARGS
!! real :: x, y, z
!! logical :: l, lbig
!! character(len=40) :: label ! FIXED LENGTH
@@ -94,15 +94,15 @@
!! character(len=:),allocatable :: title ! VARIABLE LENGTH
!! real :: p(3) ! FIXED SIZE
!! logical :: logi(3) ! FIXED SIZE
-!! !
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o set a value for all keywords.
-!! ! o double-quote strings, strings must be at least one space
-!! ! because adjacent double-quotes designate a double-quote
-!! ! in the value.
-!! ! o set all logical values to F
-!! ! o numeric values support an "e" or "E" exponent
-!! ! o for lists delimit with a comma, colon, or space
+!! !
+!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
+!! ! o set a value for all keywords.
+!! ! o double-quote strings, strings must be at least one space
+!! ! because adjacent double-quotes designate a double-quote
+!! ! in the value.
+!! ! o set all logical values to F
+!! ! o numeric values support an "e" or "E" exponent
+!! ! o for lists delimit with a comma, colon, or space
!! call set_args(' &
!! & -x 1 -y 2 -z 3 &
!! & -p -1 -2 -3 &
@@ -113,25 +113,34 @@
!! & --label " " &
!! ! note space between quotes is required
!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! ! non-allocatable scalars can be done up to twenty per call
+!! ! Assign values to elements using G_ARGS(3f).
+!! ! non-allocatable scalars can be done up to twenty per call
!! call get_args('x',x, 'y',y, 'z',z, 'l',l, 'L',lbig)
-!! !
-!! ! allocatables should be done one at a time
+!! ! As a convenience multiple pairs of keywords and variables may be
+!! ! specified if and only if all the values are scalars and the CHARACTER
+!! ! variables are fixed-length or pre-allocated.
+!! !
+!! ! After SET_ARGS(3f) has parsed the command line
+!! ! GET_ARGS(3f) retrieves the value of keywords accept for
+!! ! two special cases. For fixed-length CHARACTER variables
+!! ! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! ! GET_ARGS_FIXED_SIZE(3f).
+!! !
+!! ! allocatables should be done one at a time
!! call get_args('title',title) ! allocatable string
!! call get_args('point',point) ! allocatable arrays
!! call get_args('logicals',logicals)
-!! !
-!! ! less commonly ...
+!! !
+!! ! less commonly ...
!!
-!! ! for fixed-length strings
+!! ! for fixed-length strings
!! call get_args_fixed_length('label',label)
!!
-!! ! for non-allocatable arrays
+!! ! for non-allocatable arrays
!! call get_args_fixed_size('p',p)
!! call get_args_fixed_size('logi',logi)
-!! !
-!! ! all done parsing, use values
+!! !
+!! ! all done parsing, use values
!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z
!! write(*,*)'p=',p
!! write(*,*)'point=',point
@@ -141,13 +150,13 @@
!! write(*,*)'L=',lbig
!! write(*,*)'logicals=',logicals
!! write(*,*)'logi=',logi
-!! !
-!! ! unnamed strings
-!! !
+!! !
+!! ! unnamed strings
+!! !
!! if(size(filenames) > 0)then
!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames))
!! endif
-!! !
+!! !
!! end program demo_M_CLI2
!!
!!##AUTHOR
@@ -156,15 +165,15 @@
!! Public Domain
!!##SEE ALSO
!! + get_args(3f)
-!! + specified(3f)
+!! + get_args_fixed_size(3f)
+!! + get_args_fixed_length(3f)
+!! + get_subcommand(3f)
!! + set_mode(3f)
+!! + specified(3f)
!!
!! Note that the convenience routines are described under get_args(3f):
!! dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), cget(3f) dgets(3f),
!! igets(3f), lgets(3f), rgets(3f), sgets(3f), cgets(3f)
-!!
-!! + get_subcommand(3f)
-!! + get_args_fixed_size(3f), get_args_fixed_length(3f)
!===================================================================================================================================
module M_CLI2
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT, stdin=>INPUT_UNIT, stdout=>OUTPUT_UNIT, warn=>OUTPUT_UNIT
@@ -469,12 +478,12 @@ end subroutine check_commandline
!! help text is not supplied the command line initialization
!! string will be echoed.
!!
-!! VERSION_TEXT if present, any version text defined will be displayed
-!! when the program is called with a --version switch,
-!! and then the program will terminate.
-!! IERR if present a non-zero option is returned when an
-!! error occurs instead of the program terminating.
-!! ERRMSG a description of the error if ierr is present.
+!! VERSION_TEXT if present, any version text defined will be displayed
+!! when the program is called with a --version switch,
+!! and then the program will terminate.
+!! IERR if present a non-zero option is returned when an
+!! error occurs instead of the program terminating.
+!! ERRMSG a description of the error if ierr is present.
!!
!!##DEFINING THE PROTOTYPE
!!
@@ -483,9 +492,9 @@ end subroutine check_commandline
!!
!! o all keywords on the prototype MUST get a value.
!!
-!! + logicals must be set to an unquoted F.
+!! * logicals must be set to an unquoted F.
!!
-!! + strings must be delimited with double-quotes.
+!! * strings must be delimited with double-quotes.
!! Since internal double-quotes are represented with two
!! double-quotes the string must be at least one space.
!!
@@ -2710,9 +2719,9 @@ end subroutine print_dictionary
!! {real,doubleprecision,integer,logical,complex,character(len=:)}
!!##DESCRIPTION
!!
-!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f)
-!! has been called. For fixed-length CHARACTER variables
-!! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
+!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) has
+!! been called to parse the command line. For fixed-length CHARACTER
+!! variables see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see
!! GET_ARGS_FIXED_SIZE(3f).
!!
!! As a convenience multiple pairs of keywords and variables may be
@@ -2731,7 +2740,6 @@ end subroutine print_dictionary
!! list of delimiter characters may be supplied.
!!
!!##CONVENIENCE FUNCTIONS
-!!
!! There are convenience functions that are replacements for calls to
!! get_args(3f) for each supported default intrinsic type
!!
@@ -2755,31 +2763,29 @@ end subroutine print_dictionary
!! use M_CLI2, only : filenames=>unnamed, set_args, get_args
!! implicit none
!! integer :: i
-!! ! DEFINE ARGS
+!! ! Define ARGS
!! real :: x, y, z
!! real,allocatable :: p(:)
!! character(len=:),allocatable :: title
!! logical :: l, lbig
-!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE
-!! ! o only quote strings and use double-quotes
-!! ! o set all logical values to F or T.
-!! call set_args(' &
-!! & -x 1 -y 2 -z 3 &
-!! & -p -1,-2,-3 &
+!! ! Define and parse (to set initial values) command line
+!! ! o only quote strings and use double-quotes
+!! ! o set all logical values to F or T.
+!! call set_args(' &
+!! & -x 1 -y 2 -z 3 &
+!! & -p -1,-2,-3 &
!! & --title "my title" &
-!! & -l F -L F &
-!! & --label " " &
+!! & -l F -L F &
+!! & --label " " &
!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! ! SCALARS
-!! call get_args('x',x,'y',y,'z',z)
-!! call get_args('l',l)
-!! call get_args('L',lbig)
-!! ! ALLOCATABLE STRING
+!! ! Assign values to elements
+!! ! Scalars
+!! call get_args('x',x,'y',y,'z',z,'l',l,'L',lbig)
+!! ! Allocatable string
!! call get_args('title',title)
-!! ! NON-ALLOCATABLE ARRAYS
+!! ! Allocatable arrays
!! call get_args('p',p)
-!! ! USE VALUES
+!! ! Use values
!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z
!! write(*,*)'p=',p
!! write(*,*)'title=',title
@@ -2804,12 +2810,13 @@ end subroutine print_dictionary
!!
!! subroutine get_args_fixed_length(name,value)
!!
+!! character(len=*),intent(in) :: name
!! character(len=:),allocatable :: value
!! character(len=*),intent(in),optional :: delimiters
!!
!!##DESCRIPTION
!!
-!! GET_ARGS_fixed_length(3f) returns the value of a string
+!! get_args_fixed_length(3f) returns the value of a string
!! keyword when the string value is a fixed-length CHARACTER
!! variable.
!!
@@ -2831,15 +2838,16 @@ end subroutine print_dictionary
!! program demo_get_args_fixed_length
!! use M_CLI2, only : set_args, get_args_fixed_length
!! implicit none
-!! ! DEFINE ARGS
+!!
+!! ! Define args
!! character(len=80) :: title
-!! call set_args(' &
-!! & --title "my title" &
-!! & ')
-!! ! ASSIGN VALUES TO ELEMENTS
-!! call get_args_fixed_length('title',title)
-!! ! USE VALUES
-!! write(*,*)'title=',title
+!! ! Parse command line
+!! call set_args(' --title "my title" ')
+!! ! Assign values to variables
+!! call get_args_fixed_length('title',title)
+!! ! Use values
+!! write(*,*)'title=',title
+!!
!! end program demo_get_args_fixed_length
!!
!!##AUTHOR
@@ -2857,6 +2865,7 @@ end subroutine print_dictionary
!!
!! subroutine get_args_fixed_size(name,value)
!!
+!! character(len=*),intent(in) :: name
!! [real|doubleprecision|integer|logical|complex] :: value(NNN)
!! or
!! character(len=MMM) :: value(NNN)
@@ -2865,10 +2874,9 @@ end subroutine print_dictionary
!!
!!##DESCRIPTION
!!
-!! GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for
-!! fixed-size arrays after SET_ARGS(3f) has been called.
-!! On input on the command line all values of the array must
-!! be specified.
+!! get_args_fixed_size(3f) returns the value of keywords for fixed-size
+!! arrays after set_args(3f) has been called. On input on the command
+!! line all values of the array must be specified.
!!
!!##OPTIONS
!! NAME name of commandline argument to obtain the value of
diff --git a/src/Makefile b/src/Makefile
index 4129aca2..8f1caed1 100755
--- a/src/Makefile
+++ b/src/Makefile
@@ -11,6 +11,7 @@ PROGFILES = \
../example/demo7.f90 \
../example/demo8.f90 \
../example/demo9.f90 \
+ ../example/demo11.f90 \
\
../example/demo12.f90 \
../example/demo13.f90 \
@@ -166,9 +167,9 @@ man:
: INDEX OF MANPAGES TOPICS
@env MANPATH=../man MANWIDTH=256 man -k .|col -b
: MANPAGES
- @env MANPATH=../man MANWIDTH=80 man --regex '.*'|col -b
+ @env MANPATH=../man MANWIDTH=80 man -Tutf8 --regex '.*'|col -b
: SPELLING
- @env MANPATH=../man MANWIDTH=80 man --regex '.*'|col -b|spell|xargs -n 5|column -t
+ @env MANPATH=../man MANWIDTH=80 man -Tutf8 --regex '.*'|col -b|spell|xargs -n 5|column -t
.PHONY: ship
ship:
diff --git a/src/mainpage.txt b/src/mainpage.txt
index 039aa304..255bc37d 100755
--- a/src/mainpage.txt
+++ b/src/mainpage.txt
@@ -5,5 +5,5 @@
@section Introduction
command line parsing using a command prototype
- @image html html/images/swirl.gif
+ @image html html/images/M_CLI2.gif
*/'
