Fortran Wiki
A discussion on a standard command argument parser leveraging NAMELIST
proposal for a standard command argument parsing routine
Most operating systems that support command line arguments use a convention such as IEEE Std 1003.1-2001 and C getopts(3c) provide for Unix and GNU/Unix systems. Although often available from C and so potentially available by building an interface from Fortran to C using the ISO_C_BINDING interface, you are still then required to convert the string values associated with the keywords to their appropriate types.
Fortran NAMELIST groups already provide a way to define a group of variables and associated values, but NAMELIST groups cannot be associated via USE association in standard-conforming code.
If there were an extension made to allow a special NAMELIST group to be accessed at least by a special routine (let us call it GET_ARGS(3f)) then it should be as simple as the following illustrates to get command line arguments:
program illustration
use M_arguments, only : unnamed
implicit none
integer :: i
! declare and initialize a namelist
! letter_ denotes an uppercase short command keyword
! all values should be allocated before calling get_args(3f)
real :: x=111.1, y=222.2, z=333.3
real :: point(3)=[10.0,20.0,30.0]
character(len=80) :: title=" "
logical :: help=.false., version=.false.
logical :: l=.false., l_=.false., v=.false., h=.false.
! you can equivalence short and long options
equivalence (help,h),(version,v)
! just add a variable here and it is a new parameter !!
namelist /args/ x,y,z,point,title,help,h,version,v,l,l_
!
call get_args() ! crack command line options
! do stuff with your variables
end program illustration category: code
Perhaps this could be done assuming the NAMELIST is always called ‘ARGS’ or there would be a new command called ARGLIST instead of NAMELIST that was otherwise identical.
I would envision that you could pass in a procedure name as an argument that would support common standards like getopts(3c), IEEE Std 1003.1-2001, or DOS or OpenVMS syntax that would be provided by default.
Vendors and users could add additional syntax styles by providing a function that parsed the command line and returned a string in NAMELIST input format.
This would help standardize the use of Fortran programs called from command lines and prevent a standard solution for this very common problem, but leverage NAMELIST in a unique way to eliminate the step of converting all your argument values to the correct type.
Please add discussion points here …
Illustrative Example
For illustrative purposes a module is attached that comes close to the desired behavior but requires a contained routine to be added (but not changed) to the main program.
To keep the example self-contained but minimize the effort to provide it I had to include parts of several other rather large modules for manipulating simple lists and strings. That ended up making the example a bit long.
The example has only been tested with gfortran 7.0.4. Feel free to make changes to accomodate other programming environments or to otherwise improve the example.
module M_arguments
use iso_fortran_env, only : stderr=>ERROR_UNIT,stdin=>OUTPUT_UNIT ! access computing environment
implicit none
private
!===================================================================================================================================
public :: get_namelist
public :: print_dictionary
public unnamed
!===================================================================================================================================
private :: get_command_arguments_as_raw_namelist
private :: longest_command_argument
private :: namelist_to_dictionary
private :: update
private :: get
private :: wipe_dictionary
!===================================================================================================================================
private isupper ! elemental function returns .true. if CHR is an uppercase letter (A-Z)
private upper ! elemental function converts string to uppercase
private lower ! elemental function converts string to miniscule
private quote ! add quotes to string as if written with list-directed input
!===================================================================================================================================
character(len=:),allocatable :: keywords(:)
character(len=:),allocatable :: values(:)
integer,allocatable :: counts(:)
logical,allocatable :: present_in(:)
logical :: keyword_single=.true.
character(len=:),allocatable :: namelist_name
character(len=:),allocatable :: unnamed(:)
logical :: return_all
private locate ! [M_list] find PLACE in sorted character array where value can be found or should be placed
private locate_c
private insert ! [M_list] insert entry into a sorted allocatable array at specified position
private insert_c
private insert_i
private insert_l
private replace ! [M_list] 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_list] delete entry by index from a sorted allocatable array if it is present
private remove_c
private remove_i
private remove_l
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
contains
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! get_namelist(3f) - [ARGUMENTS:M_arguments] NAMELIST-based command line argument parsing
!!
!!##SYNOPSIS
!!
!! function get_namelist(definition,all) result(string)
!!
!! character(len=*),intent(in),optional :: definition
!! logical,intent(in),optional :: all
!! character(len=:),allocatable :: string
!!##DESCRIPTION
!!
!! parse command line options
!!
!! This routine leverages NAMELIST groups to do the conversion from strings
!! to numeric values required by other command line parsers.
!!
!! There is no need to convert from strings to numeric
!! values in the source code. Even arrays and user-defined types can be
!! used, complex values can be input ... just define the variable and
!! add it to the NAMELIST definition.
!!
!! To use the routine
!!
!! o define a NAMELIST group called ARGS. Initialize all the values.
!! o write the NAMELIST group to a character variable so the parser has
!! information on which keywords are LOGICAL, CHARACTER, or numeric.
!! o call the routine that returns the command line as a string in namelist format
!! o namelist()
!! direct NAMELIST syntax in KEYWORD=VALUE pairs
!! o namelist_values()
!! -KEYWORD VALUE syntax
!! o getopts()
!! o read that string as a namelist
!!
!! Note that since all the arguments are defined in a NAMELIST group
!! that config files can easily be used for the same options.
!! Just create a NAMELIST input file and read it.
!!
!! NAMELIST syntax can vary between different programming environments.
!! Currently, this routine has only been tested using gfortran 7.0.4;
!! and requires at least Fortran 2003.
!!
!! PASS IN A NAMELIST STRING
!!
!! If you want to pass in options using syntax similar to that provided
!! by the C getopts(3c) procedure pass in a NAMELIST string. Typically,
!! you would generate the input string by writing the NAMELIST group to
!! an internal file.
!!
!! The following program can be called using commands like
!!
!! cmd -A 'string Value' -l -V --help -p 3.4,5.6 -- *
!!
!! Typical program skeleton:
!!
!! program short
!! use M_arguments, only : unnamed
!! implicit none
!! integer :: i
!!
!! ! declare and initialize a namelist
!! ! letter_ denotes an uppercase short command keyword
!! ! all values should be allocated before calling get_args(3f)
!! real :: x=111.1, y=222.2, z=333.3
!! real :: point(3)=[10.0,20.0,30.0]
!! character(len=80) :: title=" "
!! logical :: help=.false., version=.false.
!! logical :: l=.false., l_=.false., v=.false., h=.false.
!! ! you can equivalence short and long options
!! equivalence (help,h),(version,v)
!! ! just add a variable here and it is a new parameter !!
!! namelist /args/ x,y,z,point,title,help,h,version,v,l,l_
!! !
!! call get_args() ! crack command line options and apply to namelist
!! ! do stuff with your variables
!! write(*,*)'VALUES ARE NOW'
!! write(*,nml=args)
!! if(size(unnamed).gt.0)then
!! write(*,'(a)')'UNNAMED:'
!! write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
!! endif
!! contains
!! subroutine get_args()
!! ! The NAMELIST cannot be passed as an option to a routine so this
!! ! routine must be in a contained routine or directly in the body of
!! ! the routine that declares the NAMELIST. get_args(3f) should not
!! ! need changed except for possibly the length of HOLD_NAMELIST
!! use M_arguments, only : get_namelist, print_dictionary
!! !
!! integer :: ios, i
!! character(len=255) :: message ! use for I/O error messages
!! character(len=:),allocatable :: readme ! stores updated namelist
!! ! make big enough for all of namelist
!! character(len=10000) :: hold_namelist
!! ! the routine needs a copy of the options to determine what values
!! ! are character and logical versus numeric
!! write(hold_namelist,nml=args,iostat=ios,iomsg=message)
!! if(ios.eq.0)then
!! ! pass in the namelist and get an updated copy that includes
!! ! values specified on the command line
!! readme=get_namelist(hold_namelist)
!! ! read the updated namelist to update the values
!! ! in the namelist group
!! read(readme,nml=args,iostat=ios,iomsg=message)
!! endif
!! if(ios.ne.0)then
!! write(*,'("ERROR:",i0,1x,a)')ios, trim(message)
!! call print_dictionary()
!! stop 1
!! endif
!! ! all done cracking the command line
!! end subroutine get_args
!! end program short
!!
!! Instead of writing the NAMELIST group into a string you can compose
!! the string yourself. only defined names will be able to be specified
!! on the command line.
!!
!! call get_namelist('&ARGS A_="A value",B_=" ",C_=11 22 33, help=F/')
!!
!!##OPTIONS
!!
!! DESCRIPTION null or composed of all command arguments concatenated
!! into a string prepared for reading as a NAMELIST group
!! or a Unix-line command prototype string.
!!
!! o all values except logicals get a value.
!! o long names (--keyword) should be all lowercase
!! o short names (-letter) that are uppercase map to a
!! NAMELIST variable called "letter_", but lowercase
!! short names map to NAMELIST name "letter".
!! o strings MUST be delimited with double-quotes and
!! must be at least one space and internal
!! double-quotes are represented with two double-quotes
!! o lists of numbers should be comma-delimited.
!! No spaces are allowed in lists of numbers.
!! o the values follow the rules for NAMELIST values, so
!! "-p 2*0" for example would define two values.
!!
!! NOTE: IF NO DESCRIPTION IS GIVEN
!!
!! If the routine is called with no definition string arguments are passed
!! in on the command line using NAMELIST syntax (ie. KEYWORD=VALUE). This
!! is particularly suited for passing a few numeric values.
!! You can call the example program with syntax like:
!!
!! cmd r=200e3 i=200
!! cmd K=33333,J=22222,I=11111
!! cmd point = 1, 2, 3 s= -3.0e4 t = 405.5
!!
!! If you do pass in strings nested quotes or escaped double-quote
!! characters are typically required. How to do that can vary with what
!! shell and OS you are running in.
!!
!! ALL By default the output NAMELIST string only contains
!! keywords and values for names that were specified on
!! the command line. If ALL is .TRUE. a full NAMELIST
!! string is returned containing all the variables from
!! the input string.
!!##RETURNS
!!
!! STRING The output is a NAMELIST string than can be read to update
!! the NAMELIST "ARGS" with the keywords that were supplied on
!! the command line.
!!
!! When using one of the Unix-like command line forms note that
!! (subject to change) the following variations from other common
!! commnd-line parsers:
!!
!! o duplicate keywords are replaced by the rightmost entry
!!
!! o numeric keywords are not allowed; but this allows
!! negative numbers to be used as values.
!!
!! o specifying both names of an equivalenced keyword will have
!! undefined results (currrently, their alphabetical order
!! will define what the Fortran variable values become).
!!
!! o there is currently no mapping of short names to long
!! names except via an EQUIVALENCE.
!!
!! o short keywords cannot be combined. -a -b -c is required,
!! not -abc even for Boolean keys.
!!
!! o shuffling is not supported. Values must follow their
!! keywords.
!!
!! o if a parameter value of just "-" is supplied it is
!! converted to the string "stdin".
!!
!! o if the keyword "--" is encountered the rest of the
!! command arguments go into the character array "UNUSED".
!!
!! o values not matching a keyword go into the character
!! array "UNUSED".
!!
!! o long names do not take the --KEY=VALUE form, just
!! --KEY VALUE; and long names should be all lowercase and
!! always more than one character.
!!
!! o short-name parameters of the form -LETTER VALUE
!! map to a NAMELIST name of LETTER_ if uppercase
!===================================================================================================================================
function get_namelist(definition,all) result (readme)
!character(len=*),parameter::ident_2=&
!&"@(#)M_arguments::get_namelist(3f): return all command arguments as a NAMELIST(3f) string to read"
character(len=*),intent(in),optional :: definition
logical,intent(in),optional :: all
character(len=:),allocatable :: hold ! stores command line argument
character(len=:),allocatable :: readme ! stores command line argument
integer :: ibig
if(allocated(unnamed))then
deallocate(unnamed)
endif
ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine
allocate(character(len=ibig) :: unnamed(0))
if(present(all))then
return_all=all
else
return_all=.false.
endif
if(present(definition))then
call wipe_dictionary()
hold=adjustl(definition)
call namelist_to_dictionary(hold)
present_in=.false.
if(allocated(unnamed))deallocate(unnamed)
ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine
allocate(character(len=ibig) ::unnamed(0))
call cmd_args_to_dictionary(check=.true.)
call dictionary_to_namelist(readme)
else ! assume should read command line as a raw string in NAMELIST format
readme=get_command_arguments_as_raw_namelist()
endif
if(.not.allocated(unnamed))then
allocate(character(len=0) :: unnamed(0))
endif
end function get_namelist
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! get_command_arguments_as_raw_namelist(3f) - [ARGUMENTS:M_arguments] NAMELIST-based command line argument parsing
!!
!!##SYNOPSIS
!!
!! subroutine get_command_arguments_as_raw_namelist(string)
!!
!! character(len=:),allocatable,intent(out) :: string
!!##DESCRIPTION
!!
!! NAMELIST can be used to pass keyword-value pairs via the command
!! line. the following example program simply needs an initialized
!! variable added to the NAMELIST and it automatically is available as
!! a command line argument. Hard to imagine it getting much simpler.
!!
!! You can call the example program with syntax like:
!!
!! testit r=200e3 i=200
!! testit K=33333,J=22222,I=11111
!!
!! Note that if you pass in strings you probably will have to use nested
!! quotes or escape your quote characters. How you do that can vary with
!! what shell and OS you are running in.
!!
!! # just quote the entire argument list with single quotes ...
!! testit 'c="my character string" S=10,T=20.30,R=3e-2'
!!
!! or nest the quotes ...
!! testit c='"string"' S=20.30
!!
!! or escape the quotes ...
!! testit c=\"string\"
!!
!! As you will see, there is no need to convert from strings to numeric
!! values in the source code. Even arrays and user-defined types can be
!! used, complex values can be input ... just define the variable and
!! add it to the NAMELIST definition.
!!
!! And if you want to use a config file instead of command line arguments
!! since your arguments are defined in a NAMELIST group just create a
!! NAMELIST input file and read it.
!!
!!##RETURNS
!! STRING composed of all command arguments concatenated into a string
!! prepared for reading as a NAMELIST.
!!
!===================================================================================================================================
function get_command_arguments_as_raw_namelist() result (string)
!character(len=*),parameter::ident_3="&
!&@(#)M_arguments::get_command_arguments_as_raw_namelist(3f): return all command arguments as a NAMELIST(3f) string"
character(len=:),allocatable :: string ! stores command line argument
character(len=:),allocatable :: string_bug ! bug in gfortran 7.4.0 where string in LHS and RHS causes problems
integer :: command_line_length
call get_command(length=command_line_length) ! get length needed to hold command
allocate(character(len=command_line_length) :: string)
call get_command(string)
! trim off command name and get command line arguments
string_bug=adjustl(string)//' ' ! assuming command verb does not have spaces in it
string=string_bug(index(string_bug,' '):)
string="&ARGS "//string//" /" ! add namelist prefix and terminator
end function get_command_arguments_as_raw_namelist
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! update(3f) - [ARGUMENTS:M_arguments] update internal dictionary given keyword and value
!!##SYNOPSIS
!!
!! subroutine update(key,val)
!!
!! character(len=*),intent(in) :: key
!! character(len=*),intent(in),optional :: val
!!##DESCRIPTION
!! Update internal dictionary in M_arguments(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.
!!##RETURNS
!!##EXAMPLE
!!
!===================================================================================================================================
subroutine update(key,val)
character(len=*),intent(in) :: key
character(len=*),intent(in),optional :: val
integer :: place
integer :: ilen
character(len=:),allocatable :: val_local
if(present(val))then
val_local=val
ilen=len_trim(val_local)
call locate(keywords,key,place) ! find where string is or should be
if(place.lt.1)then ! if string was not found insert it
call insert(keywords,key,iabs(place))
call insert(values,val_local,iabs(place))
call insert(counts,ilen,iabs(place))
call insert(present_in,.true.,iabs(place))
else
call replace(values,val_local,place)
call replace(counts,ilen,place)
call replace(present_in,.true.,place)
endif
else ! if no value is present remove the keyword and related values
call locate(keywords,key,place)
if(place.gt.0)then
call remove(keywords,place)
call remove(values,place)
call remove(counts,place)
call remove(present_in,place)
endif
endif
end subroutine update
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! wipe_dictionary(3fp) - [ARGUMENTS:M_arguments] reset private M_arguments(3fm) dictionary to empty
!!##SYNOPSIS
!!
!! subroutine wipe_dictionary()
!!##DESCRIPTION
!! reset private M_arguments(3fm) dictionary to empty
!!##EXAMPLE
!!
!! program demo_wipe_dictionary
!! use M_arguments, only : dictionary
!! call wipe_dictionary()
!! end program demo_wipe_dictionary
!===================================================================================================================================
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(present_in))deallocate(present_in)
allocate(present_in(0))
end subroutine wipe_dictionary
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##SYNOPSIS
!!
!! get(3f) - [ARGUMENTS:M_arguments] get dictionary value associated with key name in private M_arguments(3fm) dictionary
!!##DESCRIPTION
!! Get dictionary value associated with key name in private M_arguments(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(keywords,key,place)
if(place.lt.1)then
valout=''
else
valout=values(place)(:counts(place))
endif
end function get
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine cmd_args_to_dictionary(check)
! convert command line arguments to dictionary entries
! reading the namelist output will trap unknown option names so do not really need to trap them here
logical,intent(in),optional :: check
logical :: check_local
integer :: pointer
character(len=:),allocatable :: lastkeyword
integer :: i
integer :: ilength, istatus, imax
character(len=:),allocatable :: current_argument
character(len=:),allocatable :: current_argument_padded
character(len=:),allocatable :: dummy
character(len=:),allocatable :: oldvalue
logical :: nomore
if(present(check))then
check_local=check
else
check_local=.false.
endif
nomore=.false.
pointer=0
lastkeyword=' '
keyword_single=.true.
GET_ARGS: do i=1, command_argument_count() ! insert and replace entries
call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument
if(istatus /= 0) then ! stop program on error
write(stderr,*)'*cmd_args_to_dictionary* error obtaining argument ',i,&
&'status=',istatus,&
&'length=',ilength
exit GET_ARGS
else
if(allocated(current_argument))deallocate(current_argument)
ilength=max(ilength,1)
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 ! stop program on error
write(stderr,*)'*cmd_args_to_dictionary* error obtaining argument ',i,&
&'status=',istatus,&
&'length=',ilength,&
&'target length=',len(current_argument)
exit GET_ARGS
endif
endif
if(current_argument.eq.'-')then ! sort of
current_argument='"stdin"'
endif
if(current_argument.eq.'--')then ! everything after this goes into the unnamed array
nomore=.true.
pointer=0
cycle
endif
dummy=current_argument//' '
current_argument_padded=current_argument//' '
if(.not.nomore.and.current_argument_padded(1:2).eq.'--'.and.index("0123456789.",dummy(3:3)).eq.0)then ! beginning of long word
keyword_single=.false.
if(lastkeyword.ne.'')then
call ifnull()
endif
call locate(keywords,current_argument_padded(3:),pointer)
if(pointer.le.0.and.check_local)then
call print_dictionary('UNKNOWN LONG KEYWORD: '//current_argument)
stop 1
endif
lastkeyword=trim(current_argument_padded(3:))
elseif(.not.nomore.and.current_argument_padded(1:1).eq.'-'.and.index("0123456789.",dummy(2:2)).eq.0)then ! short word
keyword_single=.true.
if(lastkeyword.ne.'')then
call ifnull()
endif
call locate(keywords,current_argument_padded(2:),pointer)
if(pointer.le.0.and.check_local)then
call print_dictionary('UNKNOWN SHORT KEYWORD: '//current_argument)
stop 2
endif
lastkeyword=trim(current_argument_padded(2:))
elseif(pointer.eq.0)then ! unnamed arguments
imax=max(len(unnamed),len(current_argument))
unnamed=[character(len=imax) :: unnamed,current_argument]
else
oldvalue=get(keywords(pointer))//' '
if(oldvalue(1:1).eq.'"')then
current_argument=quote(current_argument(:ilength))
endif
if(upper(oldvalue).eq.'F'.or.upper(oldvalue).eq.'T')then ! assume boolean parameter
if(current_argument.ne.' ')then
imax=max(len(unnamed),len(current_argument))
unnamed=[character(len=imax) :: unnamed,current_argument]
endif
current_argument='T'
endif
call update(keywords(pointer),current_argument)
pointer=0
lastkeyword=''
endif
enddo GET_ARGS
if(lastkeyword.ne.'')then
call ifnull()
endif
contains
subroutine ifnull()
oldvalue=get(lastkeyword)//' '
if(upper(oldvalue).eq.'F'.or.upper(oldvalue).eq.'T')then
call update(lastkeyword,'T')
elseif(oldvalue(1:1).eq.'"')then
call update(lastkeyword,'" "')
else
call update(lastkeyword,' ')
endif
end subroutine ifnull
end subroutine cmd_args_to_dictionary
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
subroutine dictionary_to_namelist(nml)
character(len=:),allocatable,intent(out) :: nml
integer :: i
character(len=:),allocatable :: newkeyword
! build namelist string
nml=namelist_name//' '
do i=1,size(keywords)
if(isupper(keywords(i)(1:1)))then
newkeyword=trim(lower(keywords(i)))//'_'
else
newkeyword=trim(keywords(i))
endif
if(return_all.or.present_in(i))then
nml=nml//newkeyword//'='//trim(values(i))//' '
endif
enddo
nml=nml//' /'
end subroutine dictionary_to_namelist
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!##SYNOPSIS
!!
!! subroutine print_dictionary(header)
!!
!! character(len=*),intent(in),optional :: header
!!##DESCRIPTION
!! Print the internal dictionary created by calls to get_namelist(3f).
!! This routine is intended to print the state of the argument list
!! if an error occurs in using the get_namelist(3f) procedure..
!!##OPTIONS
!! HEADER label to print before printing the state of the command
!! argument list.
!!##EXAMPLE
!!
!! Typical usage:
!!
!! program demo_get_namelist
!! use M_arguments, only : unnamed, get_namelist, print_dictionary
!! implicit none
!! integer :: i
!! character(len=255) :: message ! use for I/O error message
!! character(len=:),allocatable :: readme ! stores updated namelist
!! integer :: ios
!! real :: x, y, z
!! logical :: help, h
!! equivalence (help,h)
!! namelist /args/ x,y,z,help,h
!! character(len=*),parameter :: cmd='&ARGS X=1 Y=2 Z=3 HELP=F H=F /'
!! ! initialize namelist from string and then update from command line
!! readme=cmd
!! read(readme,nml=args,iostat=ios,iomsg=message)
!! if(ios.eq.0)then
!! ! update cmd with options from command line
!! readme=get_namelist(cmd)
!! read(readme,nml=args,iostat=ios,iomsg=message)
!! endif
!! if(ios.ne.0)then
!! write(*,'("ERROR:",i0,1x,a)')ios, trim(message)
!! call print_dictionary('OPTIONS:')
!! stop 1
!! endif
!! ! all done cracking the command line
!! ! use the values in your program.
!! write(*,nml=args)
!! ! the optional unnamed values on the command line are
!! ! accumulated in the character array "UNNAMED"
!! if(size(unnamed).gt.0)then
!! write(*,'(a)')'files:'
!! write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
!! endif
!! end program demo_get_namelist
!===================================================================================================================================
subroutine print_dictionary(header)
character(len=*),intent(in),optional :: header
integer :: i
if(present(header))then
if(header.ne.'')then
write(stderr,'(a)')header
endif
endif
if(allocated(keywords))then
if(size(keywords).gt.0)then
write(stderr,'(*(a,t21,a,t30,a))')'KEYWORD','PRESENT','VALUE'
write(stderr,'(*(a,t21,l0,t30,"[",a,"]",/))')(trim(keywords(i)),present_in(i),values(i)(:counts(i)),i=1,size(keywords))
endif
endif
if(allocated(unnamed))then
if(size(unnamed).gt.0)then
write(stderr,'(a)')'UNNAMED'
write(stderr,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
endif
endif
end subroutine print_dictionary
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! longest_command_argument(3f) - [ARGUMENTS:M_arguments] length of longest argument on command line
!!##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_arguments, only : longest_command_argument
!! write(*,*)'longest argument is ',longest_command_argument()
!! end program demo_longest_command_argument
!===================================================================================================================================
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 throught command line arguments to find longest
call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument
if(istatus /= 0) then ! stop program on error
write(stderr,*)'*longest_command_argument* error obtaining length for argument ',i
exit GET_LONGEST
elseif(ilength.gt.0)then
ilongest=max(ilongest,ilength)
endif
enddo GET_LONGEST
end function longest_command_argument
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! namelist_to_dictionary(3f) - [ARGUMENTS:M_arguments] parse namelist string and store tokens into dictionar
!!
!!##SYNOPSIS
!!
!! subroutine namelist_to_dictionary(string)
!!
!! character(len=*),intent(in) :: string
!!
!!##DESCRIPTION
!! must start with a keyword, any keyword that appears must have a value. A character array can have more than one delimited string
!! unallocated and null values are not allowed
!! set parameter name to blank
!! find undelimited =
!! find previous , or beginning of string. inbetween is a keyword
!! = to , that starts a keyword is a value
!! one keyword and value are known store them
!!&ARGS
!! L = F,
!! A_="xxxxxxxxxxxxxxxxxxxxxxxxxx ",
!! B_="Value B ",
!! P= 2*0.00000000 ,
!! C_= 10, 20, 30, XYZ_=(-123.000000,-456.000000),
!! X= 0.0000000000000000 ,
!! Y= 0.0000000000000000 ,
!! Z= 0.0000000000000000 ,
!! /
!!
!!##OPTIONS
!! STRING string is character input string to define command
!===================================================================================================================================
subroutine namelist_to_dictionary(string)
implicit none
!character(len=*),parameter::ident_6=&
!&"@(#)M_arguments::namelist_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 :: dummy_bug ! bug in gfortran 7.4.0 where if dummy is on LHS and used in RHS get wrong result
character(len=:),allocatable :: keyword_value
character(len=:),allocatable :: value
character(len=:),allocatable :: keyword
logical :: delmt ! flag if in a delimited string or not
character(len=1) :: currnt ! current character being processed
character(len=1) :: prev ! current character being processed
integer :: islen ! number of characters in input string
integer :: ipoint
integer :: istart
integer :: iend
integer :: ileft
integer :: icut
integer :: i
integer :: iback1,iback2
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
islen=islen-1 ! by definition last character in NAMELIST output is /
dummy=trim(adjustl(string(:islen)))
! strip off namelist group name
ileft=index(dummy,'&')
dummy_bug=adjustl(dummy(ileft+1:))
ileft=index(dummy_bug,' ')
if(ileft.eq.0)then
ileft=len(dummy_bug)
endif
namelist_name=upper('&'//dummy_bug(:ileft-1))
dummy=adjustl(dummy_bug(ileft:))
islen=len(dummy)
dummy=dummy//' '
keyword="" ! initial variable name
value="" ! initial value of a string
delmt=.false. ! whether in a character string or not
prev=" "
istart=1
do ipoint=1,islen
currnt=dummy(ipoint:ipoint) ! store current character into currnt
if(currnt=="=".and..not.delmt)then ! end of a parameter name
keyword_value=''
iend=0
do i=ipoint-1,1,-1
if(dummy(i:i).eq.' ')cycle
! found non-space
iback1=index(dummy(:i),' ',back=.true.)
iback2=index(dummy(:i),',',back=.true.)
iend=max(iback1,iback2)
exit
enddo
if(iend.ne.0)then
call splitit()
endif
istart=iend+1
elseif(currnt == """")then
if(prev == """")then ! second of a double quote, put quote in
delmt=.not.delmt
elseif(delmt)then
delmt=.false.
else
delmt=.true.
endif
endif
prev=currnt
if(ipoint.ge.islen)then
iend=ipoint
call splitit()
endif
enddo
contains
subroutine splitit()
integer :: ilast
keyword_value=dummy(istart:iend)
! split keyword_value on first = and convert values to lowercase except for LETTER_ convert to uppercase LETTER and
! remove trailing , as NAMELIST output being read should not contain null values as everything in a namelist needs
! to be allocated (at least in this version of Fortran?).
icut=index(keyword_value,'=')
if(icut.eq.0)then
write(stderr,*)'*splitit* INTERNAL ERROR: KEYWORD_VALUE=['//keyword_value//']'
else
keyword=adjustl(trim(lower(keyword_value(:icut-1))))
if(len(keyword).eq.2)then
if(keyword(2:2).eq.'_')then
keyword=upper(keyword(1:1))
endif
endif
if(icut.eq.len(keyword_value))then
value=''
else
value=trim(adjustl(keyword_value(icut+1:)))
ilast=len(value)
if(ilast.eq.0)then
value=''
else
if(value(ilast:ilast).eq.',')then
value=trim(value(:ilast-1))
endif
endif
endif
call update(keyword,value)
endif
end subroutine splitit
end subroutine namelist_to_dictionary
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
pure elemental function isupper(ch) result(res)
!character(len=*),parameter::ident_66="@(#)M_strings::isupper(3f): returns true if character is an uppercase letter (A-Z)"
character,intent(in) :: ch
logical :: res
select case(ch)
case('A':'Z')
res=.true.
case default
res=.false.
end select
end function isupper
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! upper(3f) - [M_strings:CASE] changes a string to uppercase
!!
!!##SYNOPSIS
!!
!! elemental pure function upper(str,begin,end) result (string)
!!
!! character(*), intent(in) :: str
!! integer,optional,intent(in) :: begin,end
!! character(len(str)) :: string ! output string
!!##DESCRIPTION
!! upper(string) returns a copy of the input string with all characters
!! converted in the optionally specified range to uppercase, assuming
!! ASCII character sets are being used. If no range is specified the
!! entire string is converted to uppercase.
!!
!!##OPTIONS
!! str string to convert to uppercase
!! begin optional starting position in "str" to begin converting to uppercase
!! end optional ending position in "str" to stop converting to uppercase
!!
!!##RESULTS
!! upper copy of the input string with all characters converted to uppercase
!! over optionally specified range.
!!
!!##TRIVIA
!! The terms "uppercase" and "lowercase" date back to the early days of
!! the mechanical printing press. Individual metal alloy casts of each
!! needed letter, or punctuation symbol, were meticulously added to a
!! press block, by hand, before rolling out copies of a page. These
!! metal casts were stored and organized in wooden cases. The more
!! often needed miniscule letters were placed closer to hand, in the
!! lower cases of the work bench. The less often needed, capitalized,
!! majiscule letters, ended up in the harder to reach upper cases.
!!
!!##EXAMPLE
!!
!! Sample program:
!!
!! program demo_upper
!! use M_strings, only: upper
!! implicit none
!! character(len=:),allocatable :: s
!! s=' ABCDEFG abcdefg '
!! write(*,*) 'mixed-case input string is ....',s
!! write(*,*) 'upper-case output string is ...',upper(s)
!! write(*,*) 'make first character uppercase ... ',upper('this is a sentence.',1,1)
!! write(*,'(1x,a,*(a:,"+"))') 'UPPER(3f) is elemental ==>',upper(["abc","def","ghi"]
!! end program demo_upper
!!
!! Expected output
!!
!! mixed-case input string is .... ABCDEFG abcdefg
!! upper-case output string is ... ABCDEFG ABCDEFG
!! make first character uppercase ... This is a sentence.
!! UPPER(3f) is elemental ==>ABC+DEF+GHI
!===================================================================================================================================
elemental pure function upper(str,begin,end) result (string)
!character(len=*),parameter::ident_20="@(#)M_strings::upper(3f): Changes a string to uppercase"
character(*), intent(In) :: str ! inpout string to convert to all uppercase
integer, intent(in), optional :: begin,end
character(len(str)) :: string ! output string that contains no miniscule letters
integer :: i ! loop counter
integer :: ibegin,iend
string = str ! initialize output string to input string
ibegin = 1
if (present(begin))then
ibegin = max(ibegin,begin)
endif
iend = len_trim(str)
if (present(end))then
iend= min(iend,end)
endif
do i = ibegin, iend ! step thru each letter in the string in specified range
select case (str(i:i))
case ('a':'z') ! located miniscule letter
string(i:i) = char(iachar(str(i:i))-32) ! change miniscule letter to uppercase
end select
end do
end function upper
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! lower(3f) - [M_strings:CASE] changes a string to lowercase over specified rang
!!
!!##SYNOPSIS
!!
!! elemental pure function lower(str,begin,end) result (string)
!!
!! character(*), intent(in) :: str
!! integer,optional :: begin, end
!! character(len(str)) :: string ! output string
!!##DESCRIPTION
!! lower(string) returns a copy of the input string with all characters
!! converted to miniscule over the specified range, assuming ASCII
!! character sets are being used. If no range is specified the entire
!! string is converted to miniscule.
!!
!!##OPTIONS
!! str string to convert to miniscule
!! begin optional starting position in "str" to begin converting to miniscule
!! end optional ending position in "str" to stop converting to miniscule
!!
!!##RESULTS
!! lower copy of the input string with all characters converted to miniscule
!! over optionally specified range.
!!
!!##TRIVIA
!! The terms "uppercase" and "lowercase" date back to the early days of
!! the mechanical printing press. Individual metal alloy casts of each
!! needed letter, or punctuation symbol, were meticulously added to a
!! press block, by hand, before rolling out copies of a page. These
!! metal casts were stored and organized in wooden cases. The more
!! often needed miniscule letters were placed closer to hand, in the
!! lower cases of the work bench. The less often needed, capitalized,
!! majiscule letters, ended up in the harder to reach upper cases.
!!
!!##EXAMPLE
!!
!! Sample program:
!!
!! program demo_lower
!! use M_strings, only: lower
!! implicit none
!! character(len=:),allocatable :: s
!! s=' ABCDEFG abcdefg '
!! write(*,*) 'mixed-case input string is ....',s
!! write(*,*) 'lower-case output string is ...',lower(s)
!! end program demo_lower
!!
!! Expected output
!!
!! mixed-case input string is .... ABCDEFG abcdefg
!! lower-case output string is ... abcdefg abcdefg
!===================================================================================================================================
elemental pure function lower(str,begin,end) result (string)
!character(len=*),parameter::ident_21="@(#)M_strings::lower(3f): Changes a string to lowercase over specified range"
character(*), intent(In) :: str
character(len(str)) :: string
integer,intent(in),optional :: begin, end
integer :: i
integer :: ibegin, iend
string = str
ibegin = 1
if (present(begin))then
ibegin = max(ibegin,begin)
endif
iend = len_trim(str)
if (present(end))then
iend= min(iend,end)
endif
do i = ibegin, iend ! step thru each letter in the string in specified range
select case (str(i:i))
case ('A':'Z')
string(i:i) = char(iachar(str(i:i))+32) ! change letter to miniscule
case default
end select
end do
end function lower
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
!>
!!##NAME
!! quote(3f) - [M_strings:QUOTES] add quotes to string as if written with list-directed inpu
!!##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_strings, 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.ne.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
!===================================================================================================================================
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
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(merge(clip,.false.,present(clip)))then
quoted_str=adjustl(str)
else
quoted_str=str
endif
select case(lower(local_mode))
case('double')
quoted_str=double_quote//trim(replace_substring(quoted_str,'"','""'))//double_quote
case('escape')
quoted_str=double_quote//trim(replace_substring(quoted_str,'"','\"'))//double_quote
case default
write(stderr,*)'*quote* ERROR: unknown quote mode ',local_mode
quoted_str=str
end select
!-----------------------------------------------------------------------------------------------------------------------------------
end function quote
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!!NAME
!! lenset(3f) - [M_strings:LENGTH] return string trimmed or padded to specified length
!!
!!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_strings, 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 ]
function lenset(line,length) result(strout)
!@(#) M_strings::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
!! replace_substring(3f) - [M_strings:EDITING] function globally replaces one substring for another in strin
!!
!!##SYNOPSIS
!!
!! function replace_substring(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_subtring
!! use M_strings, only : replace_subtring
!! 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_substring('a b ab baaa aaaa','a','A')
!! write(*,*)'replace a with A ['//targetline//']'
!!
!! targetline=replace_substring('a b ab baaa aaaa','a','A',range=[3,5])
!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']'
!!
!! targetline=replace_substring('a b ab baaa aaaa','a','',range=[3,5])
!! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']'
!!
!! targetline=replace_substring('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_substring(targetline,old,new)
!! write(*,*)'GOT ['//targetline//']'
!! write(*,*)'EXPECTED['//expected//']'
!! write(*,*)'TEST [',targetline.eq.expected,']'
!! end subroutine testit
!!
!! end program demo_replace_substring
!!
!! 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]
!===================================================================================================================================
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.ge.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).eq.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 .eq. (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
write(stderr,*)'*crack_cmd* incorrect change directive -too short'
endif
end subroutine crack_cmd
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function replace_substring(targetline,old,new,ierr,cmd,range) result (newline)
!character(len=*),parameter::ident_9="@(#)M_strings::replace_substring(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 :: ichar
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.ne.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
write(stderr,*)'*replace_substring* 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.eq.0)then ! c//new/ means insert new at beginning of line (or left margin)
ichar=len_new + original_input_length
if(len_new.gt.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
!-----------------------------------------------------------------------------------------------------------------------------------
ichar=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.eq.ic-1.or.ind.gt.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.gt.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(:ichar-1)//targetline(ic:ind-1)
ichar=ichar+ladd
endif
if(icount.ge.range_local(1).and.icount.le.range_local(2))then ! check if this is an instance to change or keep
ichange=ichange+1
if(len_new.ne.0)then ! put in new string
newline=newline(:ichar-1)//new_local(:len_new)
ichar=ichar+len_new
endif
else
if(len_old.ne.0)then ! put in copy of old string
newline=newline(:ichar-1)//old_local(:len_old)
ichar=ichar+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.lt.len(targetline))then ! if there is more after last change on original line add it
newline=newline(:ichar-1)//targetline(ic:max(ic,original_input_length))
endif
end select
if(present(ierr))ierr=ichange
!-----------------------------------------------------------------------------------------------------------------------------------
end function replace_substring
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!! NAME
!! strtok(3f) - [M_strings:TOKENS] Tokenize a string
!! SYNOPSIS
!! function strtok(source_string,itoken,token_start,token_end,delimiters)
!! result(strtok_status)
!!
!! logical :: strtok_status ! returned value
!! character(len=*),intent(in) :: source_string ! string to tokenize
!! integer,intent(inout) :: itoken ! token count since started
!! integer,intent(out) :: token_start ! beginning of token
!! integer,intent(inout) :: token_end ! end of token
!! character(len=*),intent(in) :: delimiters ! list of separator characters
!!
!! DESCRIPTION
!! The STRTOK(3f) function is used to isolate sequential tokens in a string,
!! SOURCE_STRING. These tokens are delimited in the string by at least one of
!! the characters in DELIMITERS. The first time that STRTOK(3f) is called,
!! ITOKEN should be specified as zero. Subsequent calls, wishing to obtain
!! further tokens from the same string, should pass back in TOKEN_END and
!! ITOKEN until the function result returns .false.
!!
!! This routine assumes no other calls are made to it using any other input
!! string while it is processing an input line.
!!
!! OPTIONS
!! source_string input string to parse
!! itoken token count should be set to zero for a new string
!! delimiters characters used to determine the end of tokens
!! RETURN
!! token_start beginning position in SOURCE_STRING where token was found
!! token_end ending position in SOURCE_STRING where token was found
!! strtok_status
!!
!! EXAMPLES
!! Sample program:
!!
!! !===============================================================================
!! program demo_strtok
!! use M_strings, only : strtok
!! character(len=264) :: inline
!! character(len=*),parameter :: delimiters=' ;,'
!! integer :: ios
!! !-------------------------------------------------------------------------------
!! do ! read lines from stdin until end-of-file or error
!! read (unit=*,fmt="(a)",iostat=ios) inline
!! if(ios.ne.0)stop
!! itoken=0 ! must set ITOKEN=0 before looping on strtok(3f) on a new string.
!! do while ( strtok(inline,itoken,istart,iend,delimiters) )
!! print *, itoken,'TOKEN=['//(inline(istart:iend))//']',istart,iend
!! enddo
!! enddo
!! end program demo_strtok
!! !===============================================================================
!!
!! sample input file
!!
!! this is a test of strtok; A:B :;,C;;
!!
!! sample output file
!!
!! 1 TOKEN=[this] 2 5
!! 2 TOKEN=[is] 7 8
!! 3 TOKEN=[a] 10 10
!! 4 TOKEN=[test] 12 15
!! 5 TOKEN=[of] 17 18
!! 6 TOKEN=[strtok] 20 25
!! 7 TOKEN=[A:B] 28 30
!! 8 TOKEN=[:] 32 32
!! 9 TOKEN=[C] 35 35
!!
FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status)
! JSU- 20151030
!@(#) M_strings::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,save :: isource_len
!----------------------------------------------------------------------------------------------------------------------------
! calculate where token_start should start for this pass
if(itoken.le.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.gt.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 .le. isource_len) ! step thru each character to find next delimiter, if any
if(index(delimiters,source_string(token_start:token_start)) .ne. 0) then
token_start = token_start + 1
else
exit
endif
enddo
!----------------------------------------------------------------------------------------------------------------------------
token_end=token_start
do while (token_end .le. isource_len-1) ! step thru each character to find next delimiter, if any
if(index(delimiters,source_string(token_end+1:token_end+1)) .ne. 0) then ! found a delimiter in next character
exit
endif
token_end = token_end + 1
enddo
!----------------------------------------------------------------------------------------------------------------------------
if (token_start .gt. 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
!! merge_str(3f) - [M_strings:LENGTH] pads strings to same length and then calls MERGE(3f)
!!
!! SYNOPSIS
!! function merge_str(str1,str2,expr) result(strout)
!!
!! character(len=*),intent(in) :: str1
!! character(len=*),intent(in) :: 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.
!!
!! EXAMPLES
!! Sample Program:
!!
!! program demo_merge_str
!! use M_strings, only : merge_str
!! implicit none
!! character(len=:), allocatable :: answer
!! answer=merge_str('first string', 'second string is longer',10.eq.10)
!! write(*,'("[",a,"]")') answer
!! answer=merge_str('first string', 'second string is longer',10.ne.10)
!! write(*,'("[",a,"]")') answer
!! end program demo_merge_str
!!
!! Expected output
!!
!! [first string]
!! [second string is longer]
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
!@(#) M_strings::merge_str(3f): pads first and second arguments to MERGE(3f) to same length
character(len=*),intent(in) :: str1
character(len=*),intent(in) :: str2
logical,intent(in) :: expr
character(len=:),allocatable :: strout
integer :: big
big=max(len(str1),len(str2))
strout=trim(merge(lenset(str1,big),lenset(str2,big),expr))
end function merge_str
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!! M_list(3f) - [M_list] maintain simple lists
!!##SYNOPSIS
!!
!!##DESCRIPTION
!!
!! The M_list(3fm) module allows for maintaining an array as a sorted
!! list. An example is given that creates a keyword-value dictionary
!! using the lists.
!!
!! The lists are maintained as simple allocatable arrays. Each time an
!! entry is added or deleted the array is re-allocated. Because of the
!! expense of reallocating the data these routines are best suited for
!! maintaining small lists that do not change size frequently.
!!
!! The advantage is that the dictionary components are simple arrays
!! which can be easily accessed with standard routines.
!!
!! BASIC LIST
!! subroutine locate(list,value,place,ier,errmsg) finds the index where a
!! value is found or should
!! be in a sorted array and
!! flag if the value exists
!! already
!! subroutine insert(list,value,place) insert entry into an allocatable
!! array at specified position
!! subroutine replace(list,value,place) replace entry in an allocatable
!! array at specified position
!! subroutine remove(list,place) remove entry from an allocatable
!! array at specified position
!!
!! BASIC DICTIONARY
!!
!! Due to bugs in gfortran up to at least 7.4.0, this next section
!! does not work.
!!
!! type dictionary
!!
!! character(len=:),allocatable :: key(:)
!! character(len=:),allocatable :: value(:)
!! integer,allocatable :: count(:)
!!
!! %get get value from type(dictionary) given an existing key
!! %set set or replace value for type(dictionary) given a key
!! %del delete an existing key from type(dictionary)
!! %clr empty a type(dictionary)
!!
!!##EXAMPLE
!!
!! Sample program
!!
!! program demo_M_list
!! use M_list, only : insert, locate, replace, remove
!! ! create a dictionary with character keywords, values, and value lengths
!! ! using the routines for maintaining a list
!!
!! use M_list, only : locate, insert, replace
!! implicit none
!! character(len=:),allocatable :: keywords(:)
!! character(len=:),allocatable :: values(:)
!! integer,allocatable :: counts(:)
!! integer :: i
!! ! insert and replace entries
!! 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)),values(i)(:counts(i)),i=1,size(keywords)
!! ! remove some entries
!! call update('a')
!! call update('c')
!! write(*,'(*(a,"==>","[",a,"]",/))')(trim(keywords(i)),values(i)(:counts(i)),i=1,size(keywords)
!! ! get some values
!! write(*,*)'get b=>',get('b')
!! write(*,*)'get d=>',get('d')
!! write(*,*)'get notthere=>',get('notthere')
!!
!! contains
!! subroutine update(key,valin)
!! character(len=*),intent(in) :: key
!! character(len=*),intent(in),optional :: valin
!! integer :: place
!! integer :: ilen
!! character(len=:),allocatable :: val
!! if(present(valin))then
!! val=valin
!! ilen=len_trim(val)
!! ! find where string is or should be
!! call locate(keywords,key,place)
!! ! if string was not found insert it
!! if(place.lt.1)then
!! call insert(keywords,key,iabs(place))
!! call insert(values,val,iabs(place))
!! call insert(counts,ilen,iabs(place))
!! else
!! call replace(values,val,place)
!! call replace(counts,ilen,place)
!! endif
!! else
!! call locate(keywords,key,place)
!! if(place.gt.0)then
!! call remove(keywords,place)
!! call remove(values,place)
!! call remove(counts,place)
!! endif
!! endif
!! end subroutine update
!! 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(keywords,key,place)
!! if(place.lt.1)then
!! valout=''
!! else
!! valout=values(place)(:counts(place))
!! endif
!! end function get
!! end program demo_M_list
!!
!! Results:
!!
!! d==>[value of d]
!! c==>[value of c again]
!! b==>[value of b]
!! a==>[value of a again]
!!
!! d==>[value of d]
!! b==>[value of b]
!!
!! get b=>value of b
!! get d=>value of d
!! get notthere=>
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
!>
!!##NAME
!! locate(3f) - [M_list] finds the index where a string is found or should be in a sorted arra
!!
!!##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_list, 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=:),allocatable :: arr(:)
!! character(len=*) :: 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.lt.1)then
!! plus=abs(place)
!! ii=len(arr)
!! end=size(arr)
!! ! empty array
!! if(end.eq.0)then
!! arr=[character(len=ii) :: string ]
!! ! put in front of array
!! elseif(plus.eq.1)then
!! arr=[character(len=ii) :: string, arr]
!! ! put at end of array
!! elseif(plus.eq.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
!===================================================================================================================================
subroutine locate_c(list,value,place,ier,errmsg)
!character(len=*),parameter::ident_5="&
!&@(#)M_list::locate_c(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
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.eq.0)then
maxtry=0
place=-1
else
maxtry=int(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.eq.list(PLACE))then
exit LOOP
else if(value.gt.list(place))then
imax=place-1
else
imin=place+1
endif
if(imin.gt.imax)then
place=-imin
if(iabs(place).gt.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.gt.arraysize.or.place.le.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
else if(error.ne.0)then
write(stderr,*)message//' VALUE=',trim(value)//' PLACE=',place
stop 1
endif
if(present(errmsg))then
errmsg=message
endif
end subroutine locate_c
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
!>
!!##NAME
!! remove(3f) - [M_list] remove entry from an allocatable array at specified positio
!!
!!##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_list, 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
!===================================================================================================================================
subroutine remove_c(list,place)
!character(len=*),parameter::ident_9="@(#)M_list::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.le.0.or.place.gt.end)then ! index out of bounds of array
elseif(place.eq.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)
!character(len=*),parameter::ident_12="@(#)M_list::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.le.0.or.place.gt.end)then ! index out of bounds of array
elseif(place.eq.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)
!character(len=*),parameter::ident_13="@(#)M_list::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.le.0.or.place.gt.end)then ! index out of bounds of array
elseif(place.eq.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_list] replace entry in a string array at specified position
!!
!!##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_list, 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(keywords,'a',place)
!! if(place.gt.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(keywords,key,place)
!! ! if string was not found insert it
!! if(place.lt.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
!===================================================================================================================================
subroutine replace_c(list,value,place)
!character(len=*),parameter::ident_14="@(#)M_list::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.lt.0.or.place.gt.end)then
write(stderr,*)'*replace_c* error: index out of range. end=',end,' index=',place
elseif(len_trim(value).le.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)
!character(len=*),parameter::ident_17="@(#)M_list::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.eq.0)then ! empty array
list=[value]
elseif(place.gt.0.and.place.le.end)then
list(place)=value
else ! put in middle of array
write(stderr,*)'*replace_l* error: index out of range. end=',end,' index=',place
endif
end subroutine replace_l
!===================================================================================================================================
subroutine replace_i(list,value,place)
!character(len=*),parameter::ident_18="@(#)M_list::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.eq.0)then ! empty array
list=[value]
elseif(place.gt.0.and.place.le.end)then
list(place)=value
else ! put in middle of array
write(stderr,*)'*replace_i* error: index out of range. end=',end,' index=',place
endif
end subroutine replace_i
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()=
!===================================================================================================================================
!>
!!##NAME
!! insert(3f) - [M_list] insert entry into a string array at specified positio
!!
!!##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_list, 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.lt.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
!===================================================================================================================================
subroutine insert_c(list,value,place)
!character(len=*),parameter::ident_19="@(#)M_list::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.eq.0)then ! empty array
list=[character(len=ii) :: value ]
elseif(place.eq.1)then ! put in front of array
kludge=[character(len=ii) :: value, list]
list=kludge
elseif(place.gt.end)then ! put at end of array
kludge=[character(len=ii) :: list, value ]
list=kludge
elseif(place.ge.2.and.place.le.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(stderr,*)'*insert_c* error: index out of range. end=',end,' index=',place,' value=',value
endif
end subroutine insert_c
!===================================================================================================================================
subroutine insert_l(list,value,place)
!character(len=*),parameter::ident_22="@(#)M_list::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.eq.0)then ! empty array
list=[value]
elseif(place.eq.1)then ! put in front of array
list=[value, list]
elseif(place.gt.end)then ! put at end of array
list=[list, value ]
elseif(place.ge.2.and.place.le.end)then ! put in middle of array
list=[list(:place-1), value,list(place:) ]
else ! index out of range
write(stderr,*)'*insert_l* error: index out of range. end=',end,' index=',place,' value=',value
endif
end subroutine insert_l
!===================================================================================================================================
subroutine insert_i(list,value,place)
!character(len=*),parameter::ident_23="@(#)M_list::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.eq.0)then ! empty array
list=[value]
elseif(place.eq.1)then ! put in front of array
list=[value, list]
elseif(place.gt.end)then ! put at end of array
list=[list, value ]
elseif(place.ge.2.and.place.le.end)then ! put in middle of array
list=[list(:place-1), value,list(place:) ]
else ! index out of range
write(stderr,*)'*insert_i* error: index out of range. end=',end,' index=',place,' value=',value
endif
end subroutine insert_i
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
end module M_arguments
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================To use the module you also need to cut and paste the GET_ARGS(3f) routine shown in the example program below:
program short
use M_arguments, only : unnamed
implicit none
integer :: i
! declare and initialize a namelist
! letter_ denotes an uppercase short command keyword
! all values should be allocated before calling get_args(3f)
real :: x=111.1, y=222.2, z=333.3
real :: point(3)=[10.0,20.0,30.0]
character(len=80) :: title=" "
logical :: help=.false., version=.false.
logical :: l=.false., l_=.false., v=.false., h=.false.
! you can equivalence short and long options
equivalence (help,h),(version,v)
! just add a variable here and it is a new parameter !!
namelist /args/ x,y,z,point,title,help,h,version,v,l,l_
!
call get_args() ! crack command line options
! do stuff with your variables
write(*,*)'VALUES ARE NOW'
write(*,nml=args)
if(size(unnamed).gt.0)then
write(*,'(a)')'UNNAMED:'
write(*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed))
endif
contains
subroutine get_args()
! The NAMELIST cannot be passed as an option to a routine so this
! routine must be in a contained routine or directly in the body of
! the routine that declares the NAMELIST. get_args(3f) should not
! need changed except for possibly the length of HOLD_NAMELIST
use M_arguments, only : get_namelist, print_dictionary
!
integer :: ios
character(len=255) :: message ! use for I/O error messages
character(len=:),allocatable :: readme ! stores updated namelist
! make big enough for all of namelist
character(len=10000) :: hold_namelist
! the routine needs a copy of the options to determine what values
! are character and logical versus numeric
write(hold_namelist,nml=args,iostat=ios,iomsg=message)
if(ios.eq.0)then
! pass in the namelist and get an updated copy that includes
! values specified on the command line
readme=get_namelist(hold_namelist)
! read the updated namelist to update the values
! in the namelist group
read(readme,nml=args,iostat=ios,iomsg=message)
endif
if(ios.ne.0)then
write(*,'("ERROR:",i0,1x,a)')ios, trim(message)
call print_dictionary()
stop 1
endif
! all done cracking the command line
end subroutine get_args
end program short