diff --git a/fpm/src/M_CLI2.f90 b/fpm/src/M_CLI2.f90 new file mode 100644 index 0000000000..1edc9766a2 --- /dev/null +++ b/fpm/src/M_CLI2.f90 @@ -0,0 +1,5521 @@ +!VERSION 1.0 20200115 +!VERSION 2.0 20200802 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! M_CLI2(3fm) - [ARGUMENTS::M_CLI2] - command line argument parsing using a prototype command +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! use M_CLI2, only : set_args, get_args, unnamed, remaining +!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size +!! ! convenience functions +!! use M_CLI2, only : :: dget, iget, lget, rget, sget, cget +!! use M_CLI2, only : :: dgets, igets, lgets, rgets, sgets, cgets +!! +!!##DESCRIPTION +!! Allow for command line parsing much like standard Unix command line +!! parsing using a simple prototype. +!! +!! Typically one call to SET_ARGS(3f) is made to define the command arguments, +!! set default values, and parse the command line. Then a call is made to +!! GET_ARGS(3f) for each command keyword to obtain the argument values. +!! +!! The documentation for SET_ARGS(3f) and GET_ARGS(3f) provides further +!! details. +!! +!!##EXAMPLE +!! +!! Sample program using type conversion routines +!! +!! program demo_M_CLI2 +!! use M_CLI2, only : set_args, get_args +!! use M_CLI2, only : filenames=>unnamed +!! use M_CLI2, only : get_args_fixed_length, get_args_fixed_size +!! implicit none +!! integer :: i +!! integer,parameter :: dp=kind(0.0d0) +!! ! +!! ! DEFINE ARGS +!! real :: x, y, z +!! real(kind=dp),allocatable :: point(:) +!! logical :: l, lbig +!! logical,allocatable :: logicals(:) +!! character(len=:),allocatable :: title ! VARIABLE LENGTH +!! character(len=40) :: label ! FIXED LENGTH +!! real :: p(3) ! FIXED SIZE +!! logical :: logi(3) ! FIXED SIZE +!! ! +!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE +!! ! o set a value for all keywords. +!! ! o double-quote strings +!! ! o set all logical values to F or T. +!! ! o value delimiter is comma, colon, or space +!! call set_args(' & +!! & -x 1 -y 2 -z 3 & +!! & -p -1 -2 -3 & +!! & --point 11.11, 22.22, 33.33e0 & +!! & --title "my title" -l F -L F & +!! & --logicals F F F F F & +!! & -logi F T F & +!! ! note space between quotes is required +!! & --label " " & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! call get_args('x',x) ! SCALARS +!! call get_args('y',y) +!! call get_args('z',z) +!! call get_args('l',l) +!! call get_args('L',lbig) +!! call get_args('title',title) ! ALLOCATABLE STRING +!! call get_args('point',point) ! ALLOCATABLE ARRAYS +!! call get_args('logicals',logicals) +!! ! +!! ! for NON-ALLOCATABLE VARIABLES +!! call get_args_fixed_length('label',label) ! for non-allocatable string +!! call get_args_fixed_size('p',p) ! for non-allocatable arrays +!! call get_args_fixed_size('logi',logi) +!! ! +!! ! USE VALUES +!! write(*,*)'x=',x, 'y=',y, 'z=',z, x+y+z +!! write(*,*)'p=',p +!! write(*,*)'point=',point +!! write(*,*)'title=',title +!! write(*,*)'label=',label +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! write(*,*)'logicals=',logicals +!! write(*,*)'logi=',logi +!! ! +!! ! unnamed strings +!! ! +!! if(size(filenames).gt.0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! ! +!! end program demo_M_CLI2 +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +module M_CLI2 +use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,stdin=>INPUT_UNIT ! access computing environment +!use M_strings, only : upper, lower, quote, replace_str=>replace, unquote, split, string_to_value +!use M_list, only : insert, locate, remove, replace +!use M_args, only : longest_command_argument +!use M_journal, only : journal +implicit none +integer,parameter,private :: dp=kind(0.0d0) +private +!=================================================================================================================================== +character(len=:),allocatable,public :: unnamed(:) +character(len=:),allocatable,public :: remaining +public :: set_args +public :: get_args +public :: get_args_fixed_size +public :: get_args_fixed_length +public :: specified +public :: print_dictionary + +public :: dget, iget, lget, rget, sget, cget +public :: dgets, igets, lgets, rgets, sgets, cgets + +private :: check_commandline +private :: wipe_dictionary +private :: prototype_to_dictionary +private :: update +private :: prototype_and_cmd_args_to_nlist +private :: get + +type option + character(:),allocatable :: shortname + character(:),allocatable :: longname + character(:),allocatable :: value + integer :: length + logical :: present_in +end type option +!=================================================================================================================================== +character(len=:),allocatable :: keywords(:) +character(len=:),allocatable :: values(:) +integer,allocatable :: counts(:) +logical,allocatable :: present_in(:) + +logical :: G_keyword_single_letter=.true. +character(len=:),allocatable :: G_passed_in +logical :: G_remaining_on, G_remaining_option_allowed +character(len=:),allocatable :: G_remaining +!=================================================================================================================================== +private dictionary + +type dictionary + character(len=:),allocatable :: key(:) + character(len=:),allocatable :: value(:) + integer,allocatable :: count(:) + contains + procedure,private :: get => dict_get + procedure,private :: set => dict_add ! insert entry by name into a sorted allocatable character array if it is not present + procedure,private :: del => dict_delete ! delete entry by name from a sorted allocatable character array if it is present +end type dictionary +!================================================================================================================================== +! return allocatable arrays +interface get_args; module procedure get_anyarray_d; end interface ! any size array +interface get_args; module procedure get_anyarray_i; end interface ! any size array +interface get_args; module procedure get_anyarray_r; end interface ! any size array +interface get_args; module procedure get_anyarray_x; end interface ! any size array +interface get_args; module procedure get_anyarray_c; end interface ! any size array and any length +interface get_args; module procedure get_anyarray_l; end interface ! any size array + +! return scalars +interface get_args; module procedure get_scalar_d; end interface +interface get_args; module procedure get_scalar_i; end interface +interface get_args; module procedure get_scalar_real; end interface +interface get_args; module procedure get_scalar_complex; end interface +interface get_args; module procedure get_scalar_logical; end interface +interface get_args; module procedure get_scalar_anylength_c; end interface ! any length +! multiple scalars +interface get_args; module procedure many_args; end interface +!================================================================================================================================== +! return non-allocatable arrays +! said in conflict with get_args_*. Using class to get around that. +! that did not work either. Adding size parameter as optional parameter works; but using a different name +interface get_args_fixed_size; module procedure get_fixedarray_class; end interface ! any length, fixed size array +!interface get_args; module procedure get_fixedarray_d; end interface +!interface get_args; module procedure get_fixedarray_i; end interface +!interface get_args; module procedure get_fixedarray_r; end interface +!interface get_args; module procedure get_fixedarray_l; end interface +!interface get_args; module procedure get_fixedarray_fixed_length_c; end interface + +interface get_args_fixed_length; module procedure get_fixed_length_any_size_cxxxx; end interface ! fixed length any size array +interface get_args_fixed_length; module procedure get_scalar_fixed_length_c; end interface ! fixed length +!=================================================================================================================================== +! ident_1="@(#)M_CLI2::str(3f): {msg_scalar,msg_one}" + +private str +interface str + module procedure msg_scalar, msg_one +end interface str +!=================================================================================================================================== + +private locate ! [M_CLI2] find PLACE in sorted character array where value can be found or should be placed + private locate_c + private locate_d + private locate_r + private locate_i +private insert ! [M_CLI2] insert entry into a sorted allocatable array at specified position + private insert_c + private insert_d + private insert_r + private insert_i + private insert_l +private replace ! [M_CLI2] replace entry by index from a sorted allocatable array if it is present + private replace_c + private replace_d + private replace_r + private replace_i + private replace_l +private remove ! [M_CLI2] delete entry by index from a sorted allocatable array if it is present + private remove_c + private remove_d + private remove_r + private remove_i + private remove_l + +! Generic subroutine inserts element into allocatable array at specified position +interface locate; module procedure locate_c, locate_d, locate_r, locate_i; end interface +interface insert; module procedure insert_c, insert_d, insert_r, insert_i, insert_l; end interface +interface replace; module procedure replace_c, replace_d, replace_r, replace_i, replace_l; end interface +interface remove; module procedure remove_c, remove_d, remove_r, remove_i, remove_l; end interface +!----------------------------------------------------------------------------------------------------------------------------------- +! convenience functions +interface cgets;module procedure cgs, cg;end interface +interface dgets;module procedure dgs, dg;end interface +interface igets;module procedure igs, ig;end interface +interface lgets;module procedure lgs, lg;end interface +interface rgets;module procedure rgs, rg;end interface +interface sgets;module procedure sgs, sg;end interface +!----------------------------------------------------------------------------------------------------------------------------------- +contains +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! check_commandline(3f) - [ARGUMENTS:M_CLI2]check command and process pre-defined options +!! +!!##SYNOPSIS +!! +!! +!! subroutine check_commandline(help_text,version_text) +!! +!! character(len=:),allocatable,intent(in),allocatable,optional :: help_text(:) +!! character(len=:),allocatable,intent(in),allocatable,optional :: version_text(:) +!! +!!##DESCRIPTION +!! Checks the commandline and processes the implicit --help, --version, +!! and --usage parameters. +!! +!! If the optional text values are supplied they will be displayed by +!! --help and --version command-line options, respectively. +!! +!!##OPTIONS +!! +!! HELP_TEXT if present, will be displayed if program is called with +!! --help switch, and then the program will terminate. If +!! not supplied, the command line initialized string will be +!! shown when --help is used on the commandline. +!! +!! VERSION_TEXT if present, will be displayed if program is called with +!! --version switch, and then the program will terminate. +!! +!! If the first four characters of each line are "@(#)" this prefix will +!! not be displayed. This if for support of the SCCS what(1) command. If +!! you do not have the what(1) command on GNU/Linux and Unix platforms +!! you can probably see how it can be used to place metadata in a binary +!! by entering: +!! +!! strings demo_commandline|grep '@(#)'|tr '>' '\n'|sed -e 's/ */ /g' +!! +!!##EXAMPLE +!! +!! +!! Typical usage: +!! +!! program check_commandline +!! use M_CLI2, only : unnamed, set_args, get_args +!! implicit none +!! integer :: i +!! character(len=:),allocatable :: version_text(:), help_text(:) +!! real :: x, y, z +!! character(len=*),parameter :: cmd='-x 1 -y 2 -z 3' +!! version_text=[character(len=80) :: "version 1.0","author: me"] +!! help_text=[character(len=80) :: "wish I put instructions","here","I suppose?"] +!! call set_args(cmd,help_text,version_text) +!! call get_args('x',x,'y',y,'z',z) +!! ! All done cracking the command line. Use the values in your program. +!! write (*,*)x,y,z +!! ! the optional unnamed values on the command line are +!! ! accumulated in the character array "UNNAMED" +!! if(size(unnamed).gt.0)then +!! write (*,'(a)')'files:' +!! write (*,'(i6.6,3a)') (i,'[',unnamed(i),']',i=1,size(unnamed)) +!! endif +!! end program check_commandline +!=================================================================================================================================== +subroutine check_commandline(help_text,version_text) +character(len=:),allocatable,intent(in),optional :: help_text(:) +character(len=:),allocatable,intent(in),optional :: version_text(:) +integer :: i +integer :: istart +integer :: iback + if(get('usage').eq.'T')then + call print_dictionary('USAGE:',stop=.true.) + endif + if(present(help_text))then + if(get('help').eq.'T')then + do i=1,size(help_text) + call journal('sc',help_text(i)) + enddo + call mystop(0) + endif + elseif(get('help').eq.'T')then + DEFAULT_HELP: block + character(len=:),allocatable :: cmd_name + integer :: ilength + call get_command_argument(number=0,length=ilength) + allocate(character(len=ilength) :: cmd_name) + call get_command_argument(number=0,value=cmd_name) + G_passed_in=G_passed_in//repeat(' ',len(G_passed_in)) + call substitute(G_passed_in,' --',NEW_LINE('A')//' --') + call journal('sc',cmd_name,G_passed_in) ! no help text, echo command and default options + deallocate(cmd_name) + call mystop(0) + endblock DEFAULT_HELP + endif + if(present(version_text))then + if(get('version').eq.'T')then + istart=1 + iback=0 + if(size(version_text).gt.0)then + if(index(version_text(1),'@'//'(#)').eq.1)then ! allow for what(1) syntax + istart=5 + iback=1 + endif + endif + do i=1,size(version_text) + call journal('sc',version_text(i)(istart:len_trim(version_text(i))-iback)) + enddo + call mystop(0) + endif + elseif(get('version').eq.'T')then + call journal('sc','*check_commandline* no version text') + call mystop(0) + endif +end subroutine check_commandline +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! set_args(3f) - [ARGUMENTS:M_CLI2] command line argument parsing +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine set_args(definition,help_text,version_text) +!! +!! character(len=*),intent(in),optional :: definition +!! character(len=:),intent(in),allocatable,optional :: help_text +!! character(len=:),intent(in),allocatable,optional :: version_text +!!##DESCRIPTION +!! +!! SET_ARGS(3f) requires a unix-like command prototype for defining +!! arguments and default command-line options. Argument values are then +!! read using GET_ARGS(3f). +!! +!! The --help and --version options require the optional +!! help_text and version_text values to be provided. +!! +!!##OPTIONS +!! +!! DESCRIPTION composed of all command arguments concatenated +!! into a Unix-like command prototype string. For +!! example: +!! +!! call set_args('-L F -ints 10,20,30 -title "my title" -R 10.3') +!! +!! DESCRIPTION is pre-defined to act as if started with the reserved +!! options '--usage F --help F --version F'. The --usage +!! option is processed when the set_args(3f) +!! routine is called. The same is true for --help and --version +!! if the optional help_text and version_text options are +!! provided. +!! +!! see "DEFINING THE PROTOTYPE" in the next section for further +!! details. +!! +!! HELP_TEXT if present, will be displayed if program is called with +!! --help switch, and then the program will terminate. If +!! not supplied, the command line initialization string will be +!! shown when --help is used on the commandline. +!! +!! VERSION_TEXT if present, will be displayed if program is called with +!! --version switch, and then the program will terminate. +!! +!!##DEFINING THE PROTOTYPE +!! o all keywords on the prototype get a value. +!! o logicals must be set to F or T. +!! o strings MUST be delimited with double-quotes and +!! must be at least one space. Internal double-quotes +!! are represented with two double-quotes +!! o numeric keywords are not allowed; but this allows +!! negative numbers to be used as values. +!! o lists of values should be comma-delimited unless a +!! user-specified delimiter is used. The prototype +!! must use the same array delimiters as the call to +!! the family of get_args*(3f) called. +!! o long names (--keyword) should be all lowercase +!! o to define a zero-length allocatable array make the +!! value a delimiter (usually a comma). +!! o If the prototype ends with "--" a special mode is turned +!! on where anything after "--" on input goes into the +!! variable REMAINING instead of becoming elements in the +!! UNNAMED array. This is not needed for normal processing. +!!##USAGE +!! When invoking the program line note that (subject to change) the +!! following variations from other common command-line parsers: +!! +!! o 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 values for duplicate keywords are appended together with a space +!! separator when a command line is executed. +!! +!! o numeric keywords are not allowed; but this allows +!! negative numbers to be used as values. +!! +!! o mapping of short names to long names is demonstrated in +!! the manpage for SPECIFIED(3f). +!! +!! Specifying both names of an equivalenced keyword will have +!! undefined results (currently, their alphabetical order +!! will define what the Fortran variable values become). +!! +!! The second of the names should only be called with a +!! GET_ARGS*(3f) routine if the SPECIFIED(3f) function is .TRUE. +!! for that name. +!! +!! Note that allocatable arrays cannot be EQUIVALENCEd in Fortran. +!! +!! o short keywords cannot be combined. -a -b -c is required, +!! not -abc even for Boolean keys. +!! +!! o shuffling is not supported. Values should follow their +!! keywords. +!! +!! o if a parameter value of just "-" is supplied it is +!! converted to the string "stdin". +!! +!! o values not matching a keyword go into the character +!! array "UNUSED". +!! +!! o if the keyword "--" is encountered the rest of the +!! command arguments go into the character array "UNUSED". +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_set_args +!! use M_CLI2, only : filenames=>unnamed, set_args, get_args, unnamed +!! use M_CLI2, only : get_args_fixed_size +!! implicit none +!! integer :: i +!! ! +!! ! DEFINE ARGS +!! real :: x, y, z +!! real :: p(3) +!! character(len=:),allocatable :: title +!! logical :: l, lbig +!! integer,allocatable :: ints(:) +!! ! +!! ! DEFINE COMMAND (TO SET INITIAL VALUES AND ALLOWED KEYWORDS) +!! ! AND READ COMMAND LINE +!! call set_args(' & +!! ! reals +!! & -x 1 -y 2.3 -z 3.4e2 & +!! ! integer array +!! & -p -1,-2,-3 & +!! ! always double-quote strings +!! & --title "my title" & +!! ! set all logical values to F or T. +!! & -l F -L F & +!! ! set allocatable size to zero if you like by using a delimiter +!! & -ints , & +!! ! string should be a single character at a minimum +!! & --label " " & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! ! SCALARS +!! call get_args('x',x) +!! call get_args('y',y) +!! call get_args('z',z) +!! call get_args('l',l) +!! call get_args('L',lbig) +!! call get_args('ints',ints) ! ALLOCATABLE ARRAY +!! call get_args('title',title) ! ALLOCATABLE STRING +!! call get_args_fixed_size('p',p) ! NON-ALLOCATABLE ARRAY +!! ! USE VALUES +!! write(*,*)'x=',x +!! write(*,*)'y=',y +!! write(*,*)'z=',z +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'ints=',ints +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! ! UNNAMED VALUES +!! if(size(filenames).gt.0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! end program demo_set_args +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine set_args(prototype,help_text,version_text,string) + +! ident_2="@(#)M_CLI2::set_args(3f): parse prototype string" + +character(len=*),intent(in) :: prototype +character(len=:),intent(in),allocatable,optional :: help_text(:) +character(len=:),intent(in),allocatable,optional :: version_text(:) +character(len=*),intent(in),optional :: string +character(len=:),allocatable :: hold ! stores command line argument +integer :: ibig + G_passed_in='' + 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)) + + call wipe_dictionary() + hold='--usage F --help F --version F '//adjustl(prototype) + call prototype_and_cmd_args_to_nlist(hold,string) + + if(.not.allocated(unnamed))then + allocate(character(len=0) :: unnamed(0)) + endif + call check_commandline(help_text,version_text) ! process --help, --version, --usage +end subroutine set_args +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! prototype_to_dictionary(3f) - [ARGUMENTS:M_CLI2] parse user command and store tokens into dictionary +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! +!! subroutine prototype_to_dictionary(string) +!! +!! character(len=*),intent(in) :: string +!! +!!##DESCRIPTION +!! given a string of form +!! +!! -var value -var value +!! +!! define dictionary of form +!! +!! keyword(i), value(i) +!! +!! o string values +!! +!! o must be delimited with double quotes. +!! o adjacent double quotes put one double quote into value +!! o must not be null. A blank is specified as " ", not "". +!! +!! o logical values +!! +!! o logical values must have a value +!! +!! o leading and trailing blanks are removed from unquoted values +!! +!! +!!##OPTIONS +!! STRING string is character input string to define command +!! +!!##RETURNS +!! +!!##EXAMPLE +!! +!! sample program: +!! +!! Results: +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine prototype_to_dictionary(string) +implicit none + +! ident_3="@(#)M_CLI2::prototype_to_dictionary(3f): parse user command and store tokens into dictionary" + +character(len=*),intent(in) :: string ! string is character input string of options and values + +character(len=:),allocatable :: dummy ! working copy of string +character(len=:),allocatable :: value +character(len=:),allocatable :: keyword +character(len=3) :: delmt ! flag if in a delimited string or not +character(len=1) :: currnt ! current character being processed +character(len=1) :: prev ! character to left of CURRNT +character(len=1) :: forwrd ! character to right of CURRNT +integer,dimension(2) :: ipnt +integer :: islen ! number of characters in input string +integer :: ipoint +integer :: itype +integer,parameter :: VAL=1, KEYW=2 +integer :: ifwd +integer :: ibegin +integer :: iend +integer :: place + + islen=len_trim(string) ! find number of characters in input string + if(islen == 0)then ! if input string is blank, even default variable will not be changed + return + endif + dummy=string//' ' + + keyword="" ! initial variable name + value="" ! initial value of a string + ipoint=0 ! ipoint is the current character pointer for (dummy) + ipnt(2)=2 ! pointer to position in keyword + ipnt(1)=1 ! pointer to position in value + itype=VAL ! itype=1 for value, itype=2 for variable + + delmt="off" + prev=" " + + G_keyword_single_letter=.true. + do + ipoint=ipoint+1 ! move current character pointer forward + currnt=dummy(ipoint:ipoint) ! store current character into currnt + ifwd=min(ipoint+1,islen) ! ensure not past end of string + forwrd=dummy(ifwd:ifwd) ! next character (or duplicate if last) + + if((currnt=="-" .and. prev==" " .and. delmt == "off" .and. index("0123456789.",forwrd) == 0).or.ipoint > islen)then + ! beginning of a keyword + if(forwrd.eq.'-')then ! change --var to -var so "long" syntax is supported + !!dummy(ifwd:ifwd)='_' + ipoint=ipoint+1 ! ignore second - instead (was changing it to _) + G_keyword_single_letter=.false. ! flag this is a long keyword + else + G_keyword_single_letter=.true. ! flag this is a short (single letter) keyword + endif + if(ipnt(1)-1 >= 1)then ! position in value + ibegin=1 + iend=len_trim(value(:ipnt(1)-1)) + TESTIT: do + if(iend == 0)then ! len_trim returned 0, value is blank + iend=ibegin + exit TESTIT + elseif(value(ibegin:ibegin) == " ")then + ibegin=ibegin+1 + else + exit TESTIT + endif + enddo TESTIT + if(keyword.ne.' ')then + call update(keyword,value) ! store name and its value + elseif( G_remaining_option_allowed)then ! meaning "--" has been encountered + call update('_args_',trim(value)) + else + write(stderr,*)'*prototype_to_dictionary* warning: ignoring string ',trim(value) + endif + else + call locate(keywords,keyword,place) + if(keyword.ne.' '.and.place.lt.0)then + call update(keyword,'F') ! store name and null value (first pass) + elseif(keyword.ne.' ')then + call update(keyword,' ') ! store name and null value (second pass) + elseif(.not.G_keyword_single_letter.and.ipoint-2.eq.islen) then ! -- at end of line + G_remaining_option_allowed=.true. ! meaning for "--" is that everything on commandline goes into G_remaining + endif + endif + itype=KEYW ! change to expecting a keyword + value="" ! clear value for this variable + keyword="" ! clear variable name + ipnt(1)=1 ! restart variable value + ipnt(2)=1 ! restart variable name + + else ! currnt is not one of the special characters + ! the space after a keyword before the value + if(currnt == " ".and.itype == KEYW)then + ! switch from building a keyword string to building a value string + itype=VAL + ! beginning of a delimited value + elseif(currnt == """".and.itype == VAL)then + ! second of a double quote, put quote in + if(prev == """")then + if(itype.eq.VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + delmt="on" + elseif(delmt == "on")then ! first quote of a delimited string + delmt="off" + else + delmt="on" + endif + if(prev /= """")then ! leave quotes where found them + if(itype.eq.VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + endif + else ! add character to current keyword or value + if(itype.eq.VAL)then + value=value//currnt + else + keyword=keyword//currnt + endif + ipnt(itype)=ipnt(itype)+1 + endif + + endif + + prev=currnt + if(ipoint <= islen)then + cycle + endif + exit + enddo + +end subroutine prototype_to_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! update(3f) - [ARGUMENTS:M_CLI2] update internal dictionary given keyword and value +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! +!! +!! subroutine update(key,val) +!! +!! character(len=*),intent(in) :: key +!! character(len=*),intent(in),optional :: val +!!##DESCRIPTION +!! Update internal dictionary in M_CLI2(3fm) module. +!!##OPTIONS +!! key name of keyword to add, replace, or delete from dictionary +!! val if present add or replace value associated with keyword. If not +!! present remove keyword entry from dictionary. +!! +!! If "present" is true, a value will be appended +!!##EXAMPLE +!! +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! specified(3f) - [ARGUMENTS:M_CLI2] return true if keyword was present on command line +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! elemental impure function specified(name) +!! +!! character(len=*),intent(in) :: name +!! logical :: specified +!! +!!##DESCRIPTION +!! +!! specified(3f) returns .true. if the specified keyword was present on +!! the command line. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to query the presence of +!! +!!##RETURNS +!! SPECIFIED returns .TRUE. if specified NAME was present on the command +!! line when the program was invoked. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_specified +!! use M_CLI2, only : set_args, get_args, specified +!! implicit none +!! ! DEFINE ARGS +!! integer :: flag +!! integer,allocatable :: ints(:) +!! real,allocatable :: twonames(:) +!! +!! ! IT IS A BAD IDEA TO NOT HAVE THE SAME DEFAULT VALUE FOR ALIASED NAMES +!! ! BUT CURRENTLY YOU STILL SPECIFY THEM +!! call set_args(' -flag 1 -f 1 -ints 1,2,3 -i 1,2,3 -twonames 11.3 -T 11.3') +!! +!! ! ASSIGN VALUES TO ELEMENTS CONDITIONALLY CALLING WITH SHORT NAME +!! call get_args('flag',flag); if(specified('f'))call get_args('f',flag) +!! call get_args('ints',ints); if(specified('i'))call get_args('i',ints) +!! call get_args('twonames',twonames); if(specified('T'))call get_args('T',twonames) +!! +!! ! IF YOU WANT TO KNOW IF GROUPS OF PARAMETERS WERE SPECIFIED USE ANY(3f) and ALL(3f) +!! write(*,*)specified(['twonames','T ']) +!! write(*,*)'ANY:',any(specified(['twonames','T '])) +!! write(*,*)'ALL:',all(specified(['twonames','T '])) +!! +!! ! FOR MUTUALLY EXCLUSIVE +!! if (all(specified(['twonames','T '])))then +!! write(*,*)'You specified both names -T and -twonames' +!! endif +!! +!! ! FOR REQUIRED PARAMETER +!! if (.not.any(specified(['twonames','T '])))then +!! write(*,*)'You must specify -T or -twonames' +!! endif +!! +!! ! USE VALUES +!! write(*,*)'flag=',flag +!! write(*,*)'ints=',ints +!! write(*,*)'twonames=',twonames +!! end program demo_specified +!! +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!=================================================================================================================================== +elemental impure function specified(key) +character(len=*),intent(in) :: key +logical :: specified +integer :: place + call locate(keywords,key,place) ! find where string is or should be + if(place.lt.1)then + specified=.false. + else + specified=present_in(place) + endif +end function specified +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +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 + if(present_in(place))then ! if multiple keywords append values with space between them + if(values(place)(1:1).eq.'"')then + ! UNDESIRABLE: will ignore previous blank entries + val_local='"'//trim(unquote(values(place)))//' '//trim(unquote(val_local))//'"' + else + val_local=values(place)//' '//val_local + endif + ilen=len_trim(val_local) + endif + 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_CLI2] reset private M_CLI2(3fm) dictionary to empty +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! +!! subroutine wipe_dictionary() +!!##DESCRIPTION +!! reset private M_CLI2(3fm) dictionary to empty +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_wipe_dictionary +!! use M_CLI2, only : dictionary +!! call wipe_dictionary() +!! end program demo_wipe_dictionary +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine wipe_dictionary() + if(allocated(keywords))deallocate(keywords) + allocate(character(len=0) :: keywords(0)) + if(allocated(values))deallocate(values) + allocate(character(len=0) :: values(0)) + if(allocated(counts))deallocate(counts) + allocate(counts(0)) + if(allocated(present_in))deallocate(present_in) + allocate(present_in(0)) +end subroutine wipe_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! get(3f) - [ARGUMENTS:M_CLI2] get dictionary value associated with key name in private M_CLI2(3fm) dictionary +!!##SYNOPSIS +!! +!! +!!##DESCRIPTION +!! Get dictionary value associated with key name in private M_CLI2(3fm) dictionary. +!!##OPTIONS +!!##RETURNS +!!##EXAMPLE +!! +!=================================================================================================================================== +function get(key) result(valout) +character(len=*),intent(in) :: key +character(len=:),allocatable :: valout +integer :: place + ! find where string is or should be + call locate(keywords,key,place) + if(place.lt.1)then + valout='' + else + valout=values(place)(:counts(place)) + endif +end function get +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! prototype_and_cmd_args_to_nlist(3f) - [ARGUMENTS:M_CLI2] convert Unix-like command arguments to table +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! +!! subroutine prototype_and_cmd_args_to_nlist(prototype) +!! +!! character(len=*) :: prototype +!!##DESCRIPTION +!! create dictionary with character keywords, values, and value lengths +!! using the routines for maintaining a list from command line arguments. +!!##OPTIONS +!! prototype +!!##EXAMPLE +!! +!! +!! Sample program +!! +!! program demo_prototype_and_cmd_args_to_nlist +!! use M_CLI2, only : prototype_and_cmd_args_to_nlist, unnamed +!! implicit none +!! character(len=:),allocatable :: readme +!! character(len=256) :: message +!! integer :: ios +!! integer :: i +!! doubleprecision :: something +!! +!! ! define arguments +!! logical :: l,h,v +!! real :: p(2) +!! complex :: c +!! doubleprecision :: x,y,z +!! +!! ! uppercase keywords get an underscore to make it easier o remember +!! logical :: l_,h_,v_ +!! character(len=256) :: a_,b_ ! character variables must be long enough to hold returned value +!! integer :: c_(3) +!! +!! ! give command template with default values +!! ! all values except logicals get a value. +!! ! strings must be delimited with double quotes +!! ! A string has to have at least one character as for -A +!! ! lists of numbers should be comma-delimited. No spaces are allowed in lists of numbers +!! call prototype_and_cmd_args_to_nlist('& +!! & -l -v -h -LVH -x 0 -y 0.0 -z 0.0d0 -p 0,0 & +!! & -A " " -B "Value B" -C 10,20,30 -c (-123,-456)',readme) +!! +!! call get_args('x',x,'y',y,'z',z) +!! something=sqrt(x**2+y**2+z**2) +!! write (*,*)something,x,y,z +!! if(size(unnamed).gt.0)then +!! write (*,'(a)')'files:' +!! write (*,'(i6.6,3a)')(i,'[',unnamed(i),']',i=1,size(unnamed)) +!! endif +!! end program demo_prototype_and_cmd_args_to_nlist +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine prototype_and_cmd_args_to_nlist(prototype,string) +implicit none + +! ident_4="@(#)M_CLI2::prototype_and_cmd_args_to_nlist: create dictionary from prototype (if not null) and update from command line arguments" + +character(len=*),intent(in) :: prototype +character(len=*),intent(in),optional :: string +integer :: ibig +integer :: itrim + + G_passed_in=prototype ! make global copy for printing + + if(allocated(unnamed))deallocate(unnamed) + ibig=longest_command_argument() ! bug in gfortran. len=0 should be fine + ibig=max(ibig,1) + allocate(character(len=ibig) ::unnamed(0)) + + G_remaining_option_allowed=.false. + G_remaining_on=.false. + G_remaining='' + if(prototype.ne.'')then + call prototype_to_dictionary(prototype) ! build dictionary from prototype + present_in=.false. ! reset all values to false so everything gets written + present_in=.false. ! reset all values to false + endif + + if(present(string))then ! instead of command line arguments use another prototype string + call prototype_to_dictionary(string) ! build dictionary from prototype + else + call cmd_args_to_dictionary(check=.true.) + endif + + if(len(G_remaining).gt.1)then ! if -- was in prototype then after -- on input return rest in this string + itrim=len(G_remaining) + if(G_remaining(itrim:itrim).eq.' ')then ! was adding a space at end as building it, but do not want to remove blanks + G_remaining=G_remaining(:itrim-1) + endif + remaining=G_remaining + endif +end subroutine prototype_and_cmd_args_to_nlist +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine cmd_args_to_dictionary(check) +! convert command line arguments to dictionary entries +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=' ' + G_keyword_single_letter=.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,*)'*prototype_and_cmd_args_to_nlist* 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,*)'*prototype_and_cmd_args_to_nlist* error obtaining argument ',i,& + &'status=',istatus,& + &'length=',ilength,& + &'target length=',len(current_argument) + exit GET_ARGS + endif + endif + + if( current_argument .eq. '-' .and. nomore .eqv. .true. )then ! sort of + elseif( current_argument .eq. '-')then ! sort of + current_argument='"stdin"' + endif + if( current_argument .eq. '--' .and. nomore .eqv. .true. )then ! -- was already encountered + elseif( current_argument .eq. '--' )then ! everything after this goes into the unnamed array + nomore=.true. + pointer=0 + if(G_remaining_option_allowed)then + G_remaining_on=.true. + endif + cycle + 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 + G_keyword_single_letter=.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) + call mystop(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 + G_keyword_single_letter=.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) + call mystop(2) + endif + lastkeyword=trim(current_argument_padded(2:)) + elseif(pointer.eq.0)then ! unnamed arguments + imax=max(len(unnamed),len(current_argument)) + if(G_remaining_on)then + if(len(current_argument).lt.1)then + G_remaining=G_remaining//"'' " + elseif(current_argument(1:1).eq.'-')then + G_remaining=G_remaining//current_argument//' ' + else + G_remaining=G_remaining//"'"//current_argument//"' " + endif + else + unnamed=[character(len=imax) :: unnamed,current_argument] + endif + 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 + if(G_remaining_on)then + if(len(current_argument).lt.1)then + G_remaining=G_remaining//"'' " + elseif(current_argument(1:1).eq.'-')then + G_remaining=G_remaining//current_argument//' ' + else + G_remaining=G_remaining//"'"//current_argument//"' " + endif + else + imax=max(len(unnamed),len(current_argument)) + unnamed=[character(len=imax) :: unnamed,current_argument] + endif + 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 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! print_dictionary(3f) - [ARGUMENTS:M_CLI2] print internal dictionary created by calls to set_args(3f) +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! +!! +!! subroutine print_dictionary(header) +!! +!! character(len=*),intent(in),optional :: header +!! logical,intent(in),optional :: stop +!!##DESCRIPTION +!! Print the internal dictionary created by calls to set_args(3f). +!! This routine is intended to print the state of the argument list +!! if an error occurs in using the set_args(3f) procedure. +!!##OPTIONS +!! HEADER label to print before printing the state of the command +!! argument list. +!! STOP logical value that if true stops the program after displaying +!! the dictionary. +!!##EXAMPLE +!! +!! +!! +!! Typical usage: +!! +!! program demo_print_dictionary +!! use M_CLI2, only : set_args, get_args +!! implicit none +!! real :: x, y, z +!! call set_args('-x 10 -y 20 -z 30') +!! call get_args('x',x,'y',y,'z',z) +!! ! all done cracking the command line; use the values in your program. +!! write(*,*)x,y,z +!! end program demo_print_dictionary +!! +!! Sample output +!! +!! Calling the sample program with an unknown parameter or the --usage +!! switch produces the following: +!! +!! $ ./demo_print_dictionary -A +!! UNKNOWN SHORT KEYWORD: -A +!! KEYWORD PRESENT VALUE +!! z F [3] +!! y F [2] +!! x F [1] +!! help F [F] +!! version F [F] +!! usage F [F] +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine print_dictionary(header,stop) +character(len=*),intent(in),optional :: header +logical,intent(in),optional :: stop +integer :: i + if(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,l1,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 + if(G_remaining.ne.'')then + write(stderr,'(a)')'REMAINING' + write(stderr,'(a)')G_remaining + endif + if(present(stop))then + if(stop) call mystop(0) + endif +end subroutine print_dictionary +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +FUNCTION strtok(source_string,itoken,token_start,token_end,delimiters) result(strtok_status) +! JSU- 20151030 + +! ident_5="@(#)M_CLI2::strtok(3f): Tokenize a string" + +character(len=*),intent(in) :: source_string ! Source string to tokenize. +character(len=*),intent(in) :: delimiters ! list of separator characters. May change between calls +integer,intent(inout) :: itoken ! token count since started +logical :: strtok_status ! returned value +integer,intent(out) :: token_start ! beginning of token found if function result is .true. +integer,intent(inout) :: token_end ! end of token found if function result is .true. +integer :: isource_len +!---------------------------------------------------------------------------------------------------------------------------- +! calculate where token_start should start for this pass + if(itoken.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 +!! get_args(3f) - [ARGUMENTS:M_CLI2] return keyword values when parsing command line arguments +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! use M_CLI2, only : get_args +!! ! convenience functions +!! use M_CLI2, only : dget, iget, lget, rget, sget, cget +!! use M_CLI2, only : dgets, igets, lgets, rgets, sgets, cgets +!! +!! subroutine get_args(name,value,delimiters) +!! +!! character(len=*),intent(in) :: name +!! +!! character(len=:),allocatable :: value +!! ! or +!! character(len=:),allocatable :: value(:) +!! ! or +!! [real|doubleprecision|integer|logical|complex] :: value +!! ! or +!! [real|doubleprecision|integer|logical|complex],allocatable :: value(:) +!! +!! character(len=*),intent(in),optional :: delimiters +!! +!!##DESCRIPTION +!! +!! GET_ARGS(3f) returns the value of keywords after SET_ARGS(3f) +!! has been called. For fixed-length CHARACTER variables +!! see GET_ARGS_FIXED_LENGTH(3f). For fixed-size arrays see +!! GET_ARGS_FIXED_SIZE(3f). +!! +!! As a convenience multiple pairs of keywords and variables may be +!! specified if and only if all the values are scalars and the CHARACTER +!! variables are fixed-length or pre-allocated. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to obtain the value of +!! VALUE variable to hold returned value. The kind of the value +!! is used to determine the type of returned value. May +!! be a scalar or allocatable array. If type is CHARACTER +!! the scalar must have an allocatable length. +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##CONVENIENCE FUNCTIONS +!! +!! There are convenience functions that are replacements for calls to +!! get_args(3f) for each supported default intrinsic type +!! +!! o scalars -- dget(3f), iget(3f), lget(3f), rget(3f), sget(3f), +!! cget(3f) +!! o vectors -- dgets(3f), igets(3f), lgets(3f), rgets(3f), +!! sgets(3f), cgets(3f) +!! +!! D is for DOUBLEPRECISION, I for INTEGER, L for LOGICAL, R for REAL, +!! S for string (CHARACTER), and C for COMPLEX. +!! +!! If the functions are called with no argument they will return the +!! UNNAMED array converted to the specified type. +!! +!!##EXAMPLE +!! +!! +!! Sample program: +!! +!! program demo_get_args +!! use M_CLI2, only : filenames=>unnamed, set_args, get_args +!! implicit none +!! integer :: i +!! integer,parameter :: dp=kind(0.0d0) +!! ! DEFINE ARGS +!! real :: x, y, z +!! real,allocatable :: p(:) +!! character(len=:),allocatable :: title +!! logical :: l, lbig +!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE +!! ! o only quote strings and use double-quotes +!! ! o set all logical values to F or T. +!! call set_args(' & +!! &-x 1 -y 2 -z 3 & +!! &-p -1,-2,-3 & +!! &--title "my title" & +!! & -l F -L F & +!! & --label " " & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! ! SCALARS +!! call get_args('x',x,'y',y,'z',z) +!! call get_args('l',l) +!! call get_args('L',lbig) +!! ! ALLOCATABLE STRING +!! call get_args('title',title) +!! ! NON-ALLOCATABLE ARRAYS +!! call get_args('p',p) +!! ! USE VALUES +!! write(*,'(1x,g0,"=",g0)')'x',x, 'y',y, 'z',z +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! if(size(filenames).gt.0)then +!! write(*,'(i6.6,3a)')(i,'[',filenames(i),']',i=1,size(filenames)) +!! endif +!! end program demo_get_args +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!> +!!##NAME +!! get_args_fixed_length(3f) - [ARGUMENTS:M_CLI2] return keyword values for fixed-length string when parsing command line arguments +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine get_args_fixed_length(name,value) +!! +!! character(len=:),allocatable :: value +!! character(len=*),intent(in),optional :: delimiters +!! +!!##DESCRIPTION +!! +!! GET_ARGS_fixed_length(3f) returns the value of a string +!! keyword when the string value is a fixed-length CHARACTER +!! variable. +!! +!!##OPTIONS +!! +!! NAME name of commandline argument to obtain the value of +!! +!! VALUE variable to hold returned value. +!! Must be a fixed-length CHARACTER variable. +!! +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_get_args_fixed_length +!! use M_CLI2, only : set_args, get_args_fixed_length +!! implicit none +!! ! DEFINE ARGS +!! character(len=80) :: title +!! call set_args(' & +!! & -title "my title" & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! call get_args_fixed_length('title',title) +!! ! USE VALUES +!! write(*,*)'title=',title +!! end program demo_get_args_fixed_length +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +!> +!!##NAME +!! get_args_fixed_size(3f) - [ARGUMENTS:M_CLI2] return keyword values for fixed-size array when parsing command line arguments +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine get_args_fixed_size(name,value) +!! +!! [real|doubleprecision|integer|logical|complex] :: value(NNN) +!! or +!! character(len=MMM) :: value(NNN) +!! +!! character(len=*),intent(in),optional :: delimiters +!! +!!##DESCRIPTION +!! +!! GET_ARGS_FIXED_SIZE(3f) returns the value of keywords for +!! fixed-size arrays after SET_ARGS(3f) has been called. +!! On input on the command line all values of the array must +!! be specified. +!! +!!##OPTIONS +!! NAME name of commandline argument to obtain the value of +!! +!! VALUE variable to hold returned values. The kind of the value +!! is used to determine the type of returned value. Must be +!! a fixed-size array. If type is CHARACTER the length must +!! also be fixed. +!! +!! DELIMITERS By default the delimiter for array values are comma, +!! colon, and whitespace. A string containing an alternate +!! list of delimiter characters may be supplied. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_get_args_fixed_size +!! use M_CLI2, only : set_args, get_args_fixed_size +!! implicit none +!! integer,parameter :: dp=kind(0.0d0) +!! ! DEFINE ARGS +!! real :: x(2) +!! real(kind=dp) :: y(2) +!! integer :: p(3) +!! character(len=80) :: title(1) +!! logical :: l(4), lbig(4) +!! complex :: cmp(2) +!! ! DEFINE AND PARSE (TO SET INITIAL VALUES) COMMAND LINE +!! ! o only quote strings +!! ! o set all logical values to F or T. +!! call set_args(' & +!! & -x 10.0,20.0 & +!! & -y 11.0,22.0 & +!! & -p -1,-2,-3 & +!! & -title "my title" & +!! & -l F,T,F,T -L T,F,T,F & +!! & --cmp 111,222.0,333.0e0,4444 & +!! & ') +!! ! ASSIGN VALUES TO ELEMENTS +!! call get_args_fixed_size('x',x) +!! call get_args_fixed_size('y',y) +!! call get_args_fixed_size('p',p) +!! call get_args_fixed_size('title',title) +!! call get_args_fixed_size('l',l) +!! call get_args_fixed_size('L',lbig) +!! call get_args_fixed_size('cmp',cmp) +!! ! USE VALUES +!! write(*,*)'x=',x +!! write(*,*)'p=',p +!! write(*,*)'title=',title +!! write(*,*)'l=',l +!! write(*,*)'L=',lbig +!! write(*,*)'cmp=',cmp +!! end program demo_get_args_fixed_size +!! Results: +!! +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +subroutine get_fixedarray_class(keyword,generic,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +class(*) :: generic(:) +character(len=*),intent(in),optional :: delimiters + select type(generic) + type is (character(len=*)); call get_fixedarray_fixed_length_c(keyword,generic,delimiters) + type is (integer); call get_fixedarray_i(keyword,generic,delimiters) + type is (real); call get_fixedarray_r(keyword,generic,delimiters) + type is (complex); call get_fixed_size_complex(keyword,generic,delimiters) + type is (real(kind=dp)); call get_fixedarray_d(keyword,generic,delimiters) + type is (logical); call get_fixedarray_l(keyword,generic,delimiters) + class default + call journal('sc','*get_fixedarray_class* crud -- procedure does not know about this type') + call mystop(0) + end select +end subroutine get_fixedarray_class +!=================================================================================================================================== +! return allocatable arrays +!=================================================================================================================================== +subroutine get_anyarray_l(keyword,larray,delimiters) + +! ident_6="@(#)M_CLI2::get_anyarray_l(3f): given keyword fetch logical array from string in dictionary(F on err)" +character(len=*),intent(in) :: keyword ! the dictionary keyword (in form VERB_KEYWORD) to retrieve +logical,allocatable :: larray(:) ! convert value to an array +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: carray(:) ! convert value to an array +character(len=:),allocatable :: val +integer :: i +integer :: place +integer :: ichar ! point to first character of word unless first character is "." + call locate(keywords,keyword,place) ! find where string is or should be + if(place.gt.0)then ! if string was found + val=values(place)(:counts(place)) + call split(adjustl(upper(val)),carray,delimiters=delimiters) ! convert value to uppercase, trimmed; then parse into array + else + call journal('sc','*get_anyarray_l* unknown keyword ',keyword) + call mystop(0) + endif + if(size(carray).gt.0)then ! if not a null string + allocate(larray(size(carray))) ! allocate output array + do i=1,size(carray) + larray(i)=.false. ! initialize return value to .false. + if(carray(i)(1:1).eq.'.')then ! looking for fortran logical syntax .STRING. + ichar=2 + else + ichar=1 + endif + select case(carray(i)(ichar:ichar)) ! check word to see if true or false + case('T','Y',' '); larray(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) + case('F','N'); larray(i)=.false. ! assume this is false or no + case default + call journal('sc',"*get_anyarray_l* bad logical expression for "//trim(keyword)//'='//carray(i)) + end select + enddo + else ! for a blank string return one T + allocate(larray(1)) ! allocate output array + larray(1)=.true. + endif +end subroutine get_anyarray_l +!=================================================================================================================================== +subroutine get_anyarray_d(keyword,darray,delimiters) + +! ident_7="@(#)M_CLI2::get_anyarray_d(3f): given keyword fetch dble value array from Language Dictionary (0 on err)" + +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real(kind=dp),allocatable,intent(out) :: darray(:) ! function type +character(len=*),intent(in),optional :: delimiters + +character(len=:),allocatable :: carray(:) ! convert value to an array using split(3f) +integer :: i +integer :: place +integer :: ierr +character(len=:),allocatable :: val +!----------------------------------------------------------------------------------------------------------------------------------- + call locate(keywords,keyword,place) ! find where string is or should be + if(place.gt.0)then ! if string was found + val=values(place)(:counts(place)) + val=replace_str(val,'(','') + val=replace_str(val,')','') + call split(val,carray,delimiters=delimiters) ! find value associated with keyword and split it into an array + else + call journal('sc','*get_anyarray_d* unknown keyword ',keyword) + call mystop(0) + endif + allocate(darray(size(carray))) ! create the output array + do i=1,size(carray) + call a2d(carray(i), darray(i),ierr) ! convert the string to a numeric value + if(ierr.ne.0)then + call journal('sc','*get_anyarray_d* unreadable value',carray(i),'for keyword',keyword) + call mystop(0) + endif + enddo +end subroutine get_anyarray_d +!=================================================================================================================================== +subroutine get_anyarray_i(keyword,iarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +integer,allocatable :: iarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type + call get_anyarray_d(keyword,darray,delimiters) + iarray=nint(darray) +end subroutine get_anyarray_i +!=================================================================================================================================== +subroutine get_anyarray_r(keyword,rarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real,allocatable :: rarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type + call get_anyarray_d(keyword,darray,delimiters) +rarray=real(darray) +end subroutine get_anyarray_r +!=================================================================================================================================== +subroutine get_anyarray_x(keyword,xarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +complex,allocatable :: xarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: half,sz + call get_anyarray_d(keyword,darray,delimiters) + sz=size(darray) + half=sz/2 + if(sz.ne.half+half)then + call journal('sc','*get_anyarray_x* uneven number of values defining complex value ',keyword,' values=',sz) + call mystop(0) + endif + xarray=cmplx(real(darray(1::2)),real(darray(2::2))) +end subroutine get_anyarray_x +!=================================================================================================================================== +subroutine get_anyarray_c(keyword,strings,delimiters) + +! ident_8="@(#)M_CLI2::get_anyarray_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=:),allocatable :: strings(:) +character(len=*),intent(in),optional :: delimiters +integer :: place +character(len=:),allocatable :: val + call locate(keywords,keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,strings,delimiters=delimiters) ! find value associated with keyword and split it into an array + else + call journal('sc','*get_anyarray_c* unknown keyword ',keyword) + call mystop(0) + endif +end subroutine get_anyarray_c +!=================================================================================================================================== +subroutine get_fixed_length_any_size_cxxxx(keyword,strings,delimiters) + +! ident_9="@(#)M_CLI2::get_fixed_length_any_size_cxxxx(3f): Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=*),allocatable :: strings(:) +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: strings_a(:) +integer :: place +character(len=:),allocatable :: val + call locate(keywords,keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,strings_a,delimiters=delimiters) ! find value associated with keyword and split it into an array + if(len(strings_a).le.len(strings))then + strings=strings_a + else + call journal('sc','*get_fixed_length_any_size_cxxxx* values to long. Longest is',len(strings_a),'allowed is',len(strings)) + call journal('sc','*get_fixed_length_any_size_cxxxx* keyword=',keyword,'strings=') + write(*,'(3x,a)')strings + call mystop(0) + endif + else + call journal('sc','*get_fixed_length_any_size_cxxxx* unknown keyword ',keyword) + call mystop(0) + endif +end subroutine get_fixed_length_any_size_cxxxx +!=================================================================================================================================== +! return non-allocatable arrays +!=================================================================================================================================== +subroutine get_fixedarray_i(keyword,iarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +integer :: iarray(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: dsize + call get_anyarray_d(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(iarray,dim=1).eq.dsize)then + iarray=darray + else + call journal('sc','*get_fixedarray_i* wrong number of values for keyword',keyword,'got',dsize,'expected',size(iarray)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_fixedarray_i +!=================================================================================================================================== +subroutine get_fixedarray_r(keyword,rarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real :: rarray(:) +character(len=*),intent(in),optional :: delimiters +real,allocatable :: darray(:) ! function type +integer :: dsize + call get_anyarray_r(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(rarray,dim=1).eq.dsize)then + rarray=darray + else + call journal('sc','*get_fixedarray_r* wrong number of values for keyword',keyword,'got',dsize,'expected',size(rarray)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_fixedarray_r +!=================================================================================================================================== +subroutine get_fixed_size_complex(keyword,xarray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +complex :: xarray(:) +character(len=*),intent(in),optional :: delimiters +complex,allocatable :: darray(:) ! function type +integer :: half, sz +integer :: dsize + call get_anyarray_x(keyword,darray,delimiters) + dsize=size(darray) + sz=dsize*2 + half=sz/2 + if(sz.ne.half+half)then + call journal('sc','*get_fixed_size_complex* uneven number of values defining complex value ',keyword,' values=',sz) + call mystop(0) + endif + if(ubound(xarray,dim=1).eq.dsize)then + xarray=darray + else + call journal('sc','*get_fixed_size_complex* wrong number of values for keyword',keyword,'got',dsize,'expected',size(xarray)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_fixed_size_complex +!=================================================================================================================================== +subroutine get_fixedarray_d(keyword,darr,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real(kind=dp) :: darr(:) +character(len=*),intent(in),optional :: delimiters +real(kind=dp),allocatable :: darray(:) ! function type +integer :: dsize + call get_anyarray_d(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(darr,dim=1).eq.dsize)then + darr=darray + else + call journal('sc','*get_fixedarray_d* wrong number of values for keyword',keyword,'got',dsize,'expected',size(darr)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_fixedarray_d +!=================================================================================================================================== +subroutine get_fixedarray_l(keyword,larray,delimiters) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +logical :: larray(:) +character(len=*),intent(in),optional :: delimiters +logical,allocatable :: darray(:) ! function type +integer :: dsize + call get_anyarray_l(keyword,darray,delimiters) + dsize=size(darray) + if(ubound(larray,dim=1).eq.dsize)then + larray=darray + else + call journal('sc','*get_fixedarray_l* wrong number of values for keyword',keyword,'got',dsize,'expected',size(larray)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_fixedarray_l +!=================================================================================================================================== +subroutine get_fixedarray_fixed_length_c(keyword,strings,delimiters) + +! ident_10="@(#)M_CLI2::get_fixedarray_fixed_length_c(3f): Fetch strings value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*) :: strings(:) +character(len=*),intent(in),optional :: delimiters +character(len=:),allocatable :: str(:) +character(len=*),intent(in) :: keyword ! name to look up in dictionary +integer :: place +integer :: ssize +character(len=:),allocatable :: val + call locate(keywords,keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return strings + val=unquote(values(place)(:counts(place))) + call split(val,str,delimiters=delimiters) ! find value associated with keyword and split it into an array + ssize=size(str) + if(ssize==size(strings))then + strings(:ssize)=str + else + call journal('sc','*get_fixedarray_fixed_length_c* wrong number of values for keyword',& + & keyword,'got',ssize,'expected ',size(strings)) !,ubound(strings,dim=1) + call print_dictionary('USAGE:',stop=.true.) + endif + else + call journal('sc','*get_fixedarray_fixed_length_c* unknown keyword ',keyword) + call mystop(0) + endif +end subroutine get_fixedarray_fixed_length_c +!=================================================================================================================================== +! return scalars +!=================================================================================================================================== +subroutine get_scalar_d(keyword,d) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real(kind=dp) :: d +real(kind=dp),allocatable :: darray(:) ! function type + call get_anyarray_d(keyword,darray) + if(size(darray).eq.1)then + d=darray(1) + else + call journal('sc','*get_anyarray_d* incorrect number of values for keyword',keyword,'expected one found',size(darray)) + call print_dictionary('USAGE:',stop=.true.) + endif +end subroutine get_scalar_d +!=================================================================================================================================== +subroutine get_scalar_real(keyword,r) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +real,intent(out) :: r +real(kind=dp) :: d + call get_scalar_d(keyword,d) + r=real(d) +end subroutine get_scalar_real +!=================================================================================================================================== +subroutine get_scalar_i(keyword,i) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +integer,intent(out) :: i +real(kind=dp) :: d + call get_scalar_d(keyword,d) + i=nint(d) +end subroutine get_scalar_i +!=================================================================================================================================== +subroutine get_scalar_anylength_c(keyword,string) + +! ident_11="@(#)M_CLI2::get_scalar_anylength_c(3f): Fetch string value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=:),allocatable,intent(out) :: string +integer :: place + call locate(keywords,keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return string + string=unquote(values(place)(:counts(place))) + else + call journal('sc','*get_anyarray_c* unknown keyword ',keyword) + call mystop(0) + endif +end subroutine get_scalar_anylength_c +!=================================================================================================================================== +subroutine get_scalar_fixed_length_c(keyword,string) + +! ident_12="@(#)M_CLI2::get_scalar_fixed_length_c(3f): Fetch string value for specified KEYWORD from the lang. dictionary" + +! This routine trusts that the desired keyword exists. A blank is returned if the keyword is not in the dictionary +character(len=*),intent(in) :: keyword ! name to look up in dictionary +character(len=*),intent(out) :: string +integer :: place +integer :: unlen + call locate(keywords,keyword,place) ! find where string is or should be + if(place > 0)then ! if index is valid return string + string=unquote(values(place)(:counts(place))) + else + call journal('sc','*get_scalar_fixed_length_c* unknown keyword ',keyword) + call mystop(0) + endif + unlen=len_trim(unquote(values(place)(:counts(place)))) + if(unlen>len(string))then + call journal('sc','*get_scalar_fixed_length_c* value too long for',keyword,'allowed is',len(string),& + & 'input string [',values(place),'] is',unlen) + call mystop(0) + endif +end subroutine get_scalar_fixed_length_c +!=================================================================================================================================== +subroutine get_scalar_complex(keyword,x) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +complex,intent(out) :: x +real(kind=dp) :: d(2) + call get_fixedarray_d(keyword,d) + if(size(d).eq.2)then + x=cmplx(d(1),d(2)) + else + call journal('sc','*get_scalar_complex* incorrect number of values for keyword',keyword,'expected two found',size(d)) + call mystop(0) + endif +end subroutine get_scalar_complex +!=================================================================================================================================== +subroutine get_scalar_logical(keyword,l) +character(len=*),intent(in) :: keyword ! keyword to retrieve value for from dictionary +logical :: l +logical,allocatable :: larray(:) ! function type + call get_anyarray_l(keyword,larray) + if(size(larray).eq.1)then + l=larray(1) + else + call journal('sc','*get_anyarray_l* incorrect number of values for keyword',keyword,'expected one found',size(larray)) + call mystop(0) + endif +end subroutine get_scalar_logical +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +! THE REMAINDER SHOULD BE ROUTINES EXTRACTED FROM OTHER MODULES TO MAKE THIS MODULE STANDALONE BY POPULAR REQUEST +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!use M_strings, only : UPPER, LOWER, QUOTE, REPLACE_STR=>REPLACE, UNQUOTE, SPLIT, STRING_TO_VALUE +!use M_list, only : insert, locate, remove, replace +!use M_journal, only : JOURNAL + +!use M_args, only : LONGEST_COMMAND_ARGUMENT +! routines extracted from other modules +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! longest_command_argument(3f) - [ARGUMENTS:M_args] length of longest argument on command line +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function longest_command_argument() result(ilongest) +!! +!! integer :: ilongest +!! +!!##DESCRIPTION +!! length of longest argument on command line. Useful when allocating storage for holding arguments. +!!##RESULT +!! longest_command_argument length of longest command argument +!!##EXAMPLE +!! +!! Sample program +!! +!! program demo_longest_command_argument +!! use M_args, only : longest_command_argument +!! write(*,*)'longest argument is ',longest_command_argument() +!! end program demo_longest_command_argument +!!##AUTHOR +!! John S. Urban, 2019 +!!##LICENSE +!! Public Domain +function longest_command_argument() result(ilongest) +integer :: i +integer :: ilength +integer :: istatus +integer :: ilongest + ilength=0 + ilongest=0 + GET_LONGEST: do i=1,command_argument_count() ! loop throughout command line arguments to find longest + call get_command_argument(number=i,length=ilength,status=istatus) ! get next argument + if(istatus /= 0) then ! stop program on error + write(stderr,*)'*prototype_and_cmd_args_to_nlist* 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 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine journal(where, g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj, nospace) +implicit none + +! ident_13="@(#)M_CLI2::journal(3f): writes a message to a string composed of any standard scalar types" + +character(len=*),intent(in) :: where +class(*),intent(in) :: g0 +class(*),intent(in),optional :: g1, g2, g3, g4, g5, g6, g7, g8 ,g9 +class(*),intent(in),optional :: ga, gb, gc, gd, ge, gf, gg, gh ,gi, gj +logical,intent(in),optional :: nospace +write(*,'(a)')str(g0, g1, g2, g3, g4, g5, g6, g7, g8, g9, ga, gb, gc, gd, ge, gf, gg, gh, gi, gj ,nospace) +end subroutine journal +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! str(3f) - [M_CLI2] converts any standard scalar type to a string +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,nospace) +!! +!! class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9 +!! class(*),intent(in),optional :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj +!! logical,intent(in),optional :: nospace +!! character,len=(:),allocatable :: str +!! +!!##DESCRIPTION +!! str(3f) builds a space-separated string from up to twenty scalar values. +!! +!!##OPTIONS +!! g[0-9a-j] optional value to print the value of after the message. May +!! be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION, +!! COMPLEX, or CHARACTER. +!! +!! Optionally, all the generic values can be +!! single-dimensioned arrays. Currently, mixing scalar +!! arguments and array arguments is not supported. +!! +!! nospace if nospace=.true., then no spaces are added between values +!!##RETURNS +!! str description to print +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_msg +!! use M_CLI2, only : str +!! implicit none +!! character(len=:),allocatable :: pr +!! character(len=:),allocatable :: frmt +!! integer :: biggest +!! +!! pr=str('HUGE(3f) integers',huge(0),'and real',huge(0.0),'and double',huge(0.0d0)) +!! write(*,'(a)')pr +!! pr=str('real :',huge(0.0),0.0,12345.6789,tiny(0.0) ) +!! write(*,'(a)')pr +!! pr=str('doubleprecision :',huge(0.0d0),0.0d0,12345.6789d0,tiny(0.0d0) ) +!! write(*,'(a)')pr +!! pr=str('complex :',cmplx(huge(0.0),tiny(0.0)) ) +!! write(*,'(a)')pr +!! +!! ! create a format on the fly +!! biggest=huge(0) +!! frmt=str('(*(i',int(log10(real(biggest))),':,1x))',nospace=.true.) +!! write(*,*)'format=',frmt +!! +!! ! although it will often work, using str(3f) in an I/O statement is not recommended +!! ! because if an error occurs str(3f) will try to write while part of an I/O statement +!! ! which not all compilers can handle and is currently non-standard +!! write(*,*)str('program will now stop') +!! +!! end program demo_msg +!! +!! Output +!! +!! HUGE(3f) integers 2147483647 and real 3.40282347E+38 and double 1.7976931348623157E+308 +!! real : 3.40282347E+38 0.00000000 12345.6787 1.17549435E-38 +!! doubleprecision : 1.7976931348623157E+308 0.0000000000000000 12345.678900000001 2.2250738585072014E-308 +!! complex : (3.40282347E+38,1.17549435E-38) +!! format=(*(i9:,1x)) +!! program will now stop +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, & + & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, & + & nospace) +implicit none + +! ident_14="@(#)M_CLI2::msg_scalar(3fp): writes a message to a string composed of any standard scalar types" + +class(*),intent(in),optional :: generic0, generic1, generic2, generic3, generic4 +class(*),intent(in),optional :: generic5, generic6, generic7, generic8, generic9 +class(*),intent(in),optional :: generica, genericb, genericc, genericd, generice +class(*),intent(in),optional :: genericf, genericg, generich, generici, genericj +logical,intent(in),optional :: nospace +character(len=:), allocatable :: msg_scalar +character(len=4096) :: line +integer :: istart +integer :: increment + if(present(nospace))then + if(nospace)then + increment=1 + else + increment=2 + endif + else + increment=2 + endif + + istart=1 + line='' + if(present(generic0))call print_generic(generic0) + if(present(generic1))call print_generic(generic1) + if(present(generic2))call print_generic(generic2) + if(present(generic3))call print_generic(generic3) + if(present(generic4))call print_generic(generic4) + if(present(generic5))call print_generic(generic5) + if(present(generic6))call print_generic(generic6) + if(present(generic7))call print_generic(generic7) + if(present(generic8))call print_generic(generic8) + if(present(generic9))call print_generic(generic9) + if(present(generica))call print_generic(generica) + if(present(genericb))call print_generic(genericb) + if(present(genericc))call print_generic(genericc) + if(present(genericd))call print_generic(genericd) + if(present(generice))call print_generic(generice) + if(present(genericf))call print_generic(genericf) + if(present(genericg))call print_generic(genericg) + if(present(generich))call print_generic(generich) + if(present(generici))call print_generic(generici) + if(present(genericj))call print_generic(genericj) + msg_scalar=trim(line) +contains +!=================================================================================================================================== +subroutine print_generic(generic) +!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 +use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 +class(*),intent(in) :: generic + select type(generic) + type is (integer(kind=int8)); write(line(istart:),'(i0)') generic + type is (integer(kind=int16)); write(line(istart:),'(i0)') generic + type is (integer(kind=int32)); write(line(istart:),'(i0)') generic + type is (integer(kind=int64)); write(line(istart:),'(i0)') generic + type is (real(kind=real32)); write(line(istart:),'(1pg0)') generic + type is (real(kind=real64)); write(line(istart:),'(1pg0)') generic + type is (real(kind=real128)); write(line(istart:),'(1pg0)') generic + type is (logical); write(line(istart:),'(1l)') generic + type is (character(len=*)); write(line(istart:),'(a)') trim(generic) + type is (complex); write(line(istart:),'("(",1pg0,",",1pg0,")")') generic + end select + istart=len_trim(line)+increment +end subroutine print_generic +!=================================================================================================================================== +end function msg_scalar +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,nospace) +implicit none + +! ident_15="@(#)M_CLI2::msg_one(3fp): writes a message to a string composed of any standard one dimensional types" + +class(*),intent(in) :: generic0(:) +class(*),intent(in),optional :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:) +class(*),intent(in),optional :: generic6(:), generic7(:), generic8(:), generic9(:) +logical,intent(in),optional :: nospace +character(len=:), allocatable :: msg_one +character(len=4096) :: line +integer :: istart +integer :: increment + if(present(nospace))then + if(nospace)then + increment=1 + else + increment=2 + endif + else + increment=2 + endif + + istart=1 + line=' ' + call print_generic(generic0) + if(present(generic1))call print_generic(generic1) + if(present(generic2))call print_generic(generic2) + if(present(generic3))call print_generic(generic3) + if(present(generic4))call print_generic(generic4) + if(present(generic5))call print_generic(generic5) + if(present(generic6))call print_generic(generic6) + if(present(generic7))call print_generic(generic7) + if(present(generic8))call print_generic(generic8) + if(present(generic9))call print_generic(generic9) + msg_one=trim(line) +contains +!=================================================================================================================================== +subroutine print_generic(generic) +!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128 +use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 +class(*),intent(in),optional :: generic(:) +integer :: i + select type(generic) + type is (integer(kind=int8)); write(line(istart:),'("[",*(i0,1x))') generic + type is (integer(kind=int16)); write(line(istart:),'("[",*(i0,1x))') generic + type is (integer(kind=int32)); write(line(istart:),'("[",*(i0,1x))') generic + type is (integer(kind=int64)); write(line(istart:),'("[",*(i0,1x))') generic + type is (real(kind=real32)); write(line(istart:),'("[",*(1pg0,1x))') generic + type is (real(kind=real64)); write(line(istart:),'("[",*(1pg0,1x))') generic + type is (real(kind=real128)); write(line(istart:),'("[",*(1pg0,1x))') generic + !type is (real(kind=real256)); write(error_unit,'(1pg0)',advance='no') generic + type is (logical); write(line(istart:),'("[",*(1l,1x))') generic + type is (character(len=*)); write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic)) + type is (complex); write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic + class default + stop 'unknown type in *print_generic*' + end select + line=trim(line)//"]" + istart=len_trim(line)+increment +end subroutine print_generic +!=================================================================================================================================== +end function msg_one +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! upper(3f) - [M_CLI2:CASE] changes a string to uppercase +!! (LICENSE:PD) +!! +!!##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, +!! majuscule letters, ended up in the harder to reach upper cases. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_upper +!! use M_CLI2, 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 +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +!=================================================================================================================================== +! Timing +! +! Several different methods have been proposed for changing case. +! A simple program that copies a large file and converts it to +! uppercase was timed and compared to a simple copy. This was used +! to select the default function. +! +! NULL: 83.41user 9.25system 1:37.94elapsed 94%CPU +! upper: 101.44user 10.89system 1:58.36elapsed 94%CPU +! upper2: 105.04user 10.69system 2:04.17elapsed 93%CPU +! upper3: 267.21user 11.69system 4:49.21elapsed 96%CPU +elemental pure function upper(str,begin,end) result (string) + +! ident_16="@(#)M_CLI2::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_CLI2:CASE] changes a string to lowercase over specified range +!! (LICENSE:PD) +!! +!!##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, +!! majuscule letters, ended up in the harder to reach upper cases. +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_lower +!! use M_CLI2, 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 +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +elemental pure function lower(str,begin,end) result (string) + +! ident_17="@(#)M_CLI2::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 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine a2i(chars,valu,ierr) + +! ident_18="@(#)M_CLI2::a2i(3fp): subroutine returns integer value from string" + +character(len=*),intent(in) :: chars ! input string +integer,intent(out) :: valu ! value read from input string +integer,intent(out) :: ierr ! error flag (0 == no error) +doubleprecision :: valu8 + valu8=0.0d0 + call a2d(chars,valu8,ierr,onerr=0.0d0) + if(valu8.le.huge(valu))then + if(valu8.le.huge(valu))then + valu=int(valu8) + else + call journal('sc','*a2i*','- value too large',valu8,'>',huge(valu)) + valu=huge(valu) + ierr=-1 + endif + endif +end subroutine a2i +!---------------------------------------------------------------------------------------------------------------------------------- +subroutine a2d(chars,valu,ierr,onerr) + +! ident_19="@(#)M_CLI2::a2d(3fp): subroutine returns double value from string" + +! 1989,2016 John S. Urban. +! +! o works with any g-format input, including integer, real, and exponential. +! o if an error occurs in the read, iostat is returned in ierr and value is set to zero. If no error occurs, ierr=0. +! o if the string happens to be 'eod' no error message is produced so this string may be used to act as an end-of-data. +! IERR will still be non-zero in this case. +!---------------------------------------------------------------------------------------------------------------------------------- +character(len=*),intent(in) :: chars ! input string +character(len=:),allocatable :: local_chars +doubleprecision,intent(out) :: valu ! value read from input string +integer,intent(out) :: ierr ! error flag (0 == no error) +class(*),optional,intent(in) :: onerr +!---------------------------------------------------------------------------------------------------------------------------------- +character(len=*),parameter :: fmt="('(bn,g',i5,'.0)')" ! format used to build frmt +character(len=15) :: frmt ! holds format built to read input string +character(len=256) :: msg ! hold message from I/O errors +integer :: intg +integer :: pnd +integer :: basevalue, ivalu +character(len=3),save :: nan_string='NaN' +!---------------------------------------------------------------------------------------------------------------------------------- + ierr=0 ! initialize error flag to zero + local_chars=chars + msg='' + if(len(local_chars).eq.0)local_chars=' ' + call substitute(local_chars,',','') ! remove any comma characters + pnd=scan(local_chars,'#:') + if(pnd.ne.0)then + write(frmt,fmt)pnd-1 ! build format of form '(BN,Gn.0)' + read(local_chars(:pnd-1),fmt=frmt,iostat=ierr,iomsg=msg)basevalue ! try to read value from string + if(decodebase(local_chars(pnd+1:),basevalue,ivalu))then + valu=real(ivalu,kind=kind(0.0d0)) + else + valu=0.0d0 + ierr=-1 + endif + else + select case(local_chars(1:1)) + case('z','Z','h','H') ! assume hexadecimal + frmt='(Z'//i2s(len(local_chars))//')' + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case('b','B') ! assume binary (base 2) + frmt='(B'//i2s(len(local_chars))//')' + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case('o','O') ! assume octal + frmt='(O'//i2s(len(local_chars))//')' + read(local_chars(2:),frmt,iostat=ierr,iomsg=msg)intg + valu=dble(intg) + case default + write(frmt,fmt)len(local_chars) ! build format of form '(BN,Gn.0)' + read(local_chars,fmt=frmt,iostat=ierr,iomsg=msg)valu ! try to read value from string + end select + endif + if(ierr.ne.0)then ! if an error occurred ierr will be non-zero. + if(present(onerr))then + select type(onerr) + type is (integer) + valu=onerr + type is (real) + valu=onerr + type is (doubleprecision) + valu=onerr + end select + else ! set return value to NaN + read(nan_string,'(g3.3)')valu + endif + if(local_chars.ne.'eod')then ! print warning message except for special value "eod" + call journal('sc','*a2d* - cannot produce number from string ['//trim(chars)//']') + if(msg.ne.'')then + call journal('sc','*a2d* - ['//trim(msg)//']') + endif + endif + endif +end subroutine a2d +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! split(3f) - [M_CLI2:TOKENS] parse string into an array using specified delimiters +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine split(input_line,array,delimiters,order,nulls) +!! +!! character(len=*),intent(in) :: input_line +!! character(len=:),allocatable,intent(out) :: array(:) +!! character(len=*),optional,intent(in) :: delimiters +!! character(len=*),optional,intent(in) :: order +!! character(len=*),optional,intent(in) :: nulls +!!##DESCRIPTION +!! SPLIT(3f) parses a string using specified delimiter characters and +!! store tokens into an allocatable array +!! +!!##OPTIONS +!! +!! INPUT_LINE Input string to tokenize +!! +!! ARRAY Output array of tokens +!! +!! DELIMITERS List of delimiter characters. +!! The default delimiters are the "whitespace" characters +!! (space, tab,new line, vertical tab, formfeed, carriage +!! return, and null). You may specify an alternate set of +!! delimiter characters. +!! +!! Multi-character delimiters are not supported (Each +!! character in the DELIMITERS list is considered to be +!! a delimiter). +!! +!! Quoting of delimiter characters is not supported. +!! +!! ORDER SEQUENTIAL|REVERSE|RIGHT Order of output array. +!! By default ARRAY contains the tokens having parsed +!! the INPUT_LINE from left to right. If ORDER='RIGHT' +!! or ORDER='REVERSE' the parsing goes from right to left. +!! +!! NULLS IGNORE|RETURN|IGNOREEND Treatment of null fields. +!! By default adjacent delimiters in the input string +!! do not create an empty string in the output array. if +!! NULLS='return' adjacent delimiters create an empty element +!! in the output ARRAY. If NULLS='ignoreend' then only +!! trailing delimiters at the right of the string are ignored. +!! +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_split +!! use M_CLI2, only: split +!! character(len=*),parameter :: & +!! & line=' aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ' +!! character(len=:),allocatable :: array(:) ! output array of tokens +!! write(*,*)'INPUT LINE:['//LINE//']' +!! write(*,'(80("="))') +!! write(*,*)'typical call:' +!! CALL split(line,array) +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)'custom list of delimiters (colon and vertical line):' +!! CALL split(line,array,delimiters=':|',order='sequential',nulls='ignore') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)& +!! &'custom list of delimiters, reverse array order and count null fields:' +!! CALL split(line,array,delimiters=':|',order='reverse',nulls='return') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! write(*,'(80("-"))') +!! write(*,*)'INPUT LINE:['//LINE//']' +!! write(*,*)& +!! &'default delimiters and reverse array order and return null fields:' +!! CALL split(line,array,delimiters='',order='reverse',nulls='return') +!! write(*,'(i0," ==> ",a)')(i,trim(array(i)),i=1,size(array)) +!! write(*,*)'SIZE:',SIZE(array) +!! end program demo_split +!! +!! Output +!! +!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] +!! > =========================================================================== +!! > typical call: +!! > 1 ==> aBcdef +!! > 2 ==> ghijklmnop +!! > 3 ==> qrstuvwxyz +!! > 4 ==> 1:|:2 +!! > 5 ==> 333|333 +!! > 6 ==> a +!! > 7 ==> B +!! > 8 ==> cc +!! > SIZE: 8 +!! > -------------------------------------------------------------------------- +!! > custom list of delimiters (colon and vertical line): +!! > 1 ==> aBcdef ghijklmnop qrstuvwxyz 1 +!! > 2 ==> 2 333 +!! > 3 ==> 333 a B cc +!! > SIZE: 3 +!! > -------------------------------------------------------------------------- +!! > custom list of delimiters, reverse array order and return null fields: +!! > 1 ==> 333 a B cc +!! > 2 ==> 2 333 +!! > 3 ==> +!! > 4 ==> +!! > 5 ==> aBcdef ghijklmnop qrstuvwxyz 1 +!! > SIZE: 5 +!! > -------------------------------------------------------------------------- +!! > INPUT LINE:[ aBcdef ghijklmnop qrstuvwxyz 1:|:2 333|333 a B cc ] +!! > default delimiters and reverse array order and count null fields: +!! > 1 ==> +!! > 2 ==> +!! > 3 ==> +!! > 4 ==> cc +!! > 5 ==> B +!! > 6 ==> a +!! > 7 ==> 333|333 +!! > 8 ==> +!! > 9 ==> +!! > 10 ==> +!! > 11 ==> +!! > 12 ==> 1:|:2 +!! > 13 ==> +!! > 14 ==> qrstuvwxyz +!! > 15 ==> ghijklmnop +!! > 16 ==> +!! > 17 ==> +!! > 18 ==> aBcdef +!! > 19 ==> +!! > 20 ==> +!! > SIZE: 20 +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine split(input_line,array,delimiters,order,nulls) +!----------------------------------------------------------------------------------------------------------------------------------- + +! ident_20="@(#)M_CLI2::split(3f): parse string on delimiter characters and store tokens into an allocatable array" + +! John S. Urban +!----------------------------------------------------------------------------------------------------------------------------------- +intrinsic index, min, present, len +!----------------------------------------------------------------------------------------------------------------------------------- +! given a line of structure " par1 par2 par3 ... parn " store each par(n) into a separate variable in array. +! o by default adjacent delimiters in the input string do not create an empty string in the output array +! o no quoting of delimiters is supported +character(len=*),intent(in) :: input_line ! input string to tokenize +character(len=*),optional,intent(in) :: delimiters ! list of delimiter characters +character(len=*),optional,intent(in) :: order ! order of output array sequential|[reverse|right] +character(len=*),optional,intent(in) :: nulls ! return strings composed of delimiters or not ignore|return|ignoreend +character(len=:),allocatable,intent(out) :: array(:) ! output array of tokens +!----------------------------------------------------------------------------------------------------------------------------------- +integer :: n ! max number of strings INPUT_LINE could split into if all delimiter +integer,allocatable :: ibegin(:) ! positions in input string where tokens start +integer,allocatable :: iterm(:) ! positions in input string where tokens end +character(len=:),allocatable :: dlim ! string containing delimiter characters +character(len=:),allocatable :: ordr ! string containing order keyword +character(len=:),allocatable :: nlls ! string containing nulls keyword +integer :: ii,iiii ! loop parameters used to control print order +integer :: icount ! number of tokens found +integer :: ilen ! length of input string with trailing spaces trimmed +integer :: i10,i20,i30 ! loop counters +integer :: icol ! pointer into input string as it is being parsed +integer :: idlim ! number of delimiter characters +integer :: ifound ! where next delimiter character is found in remaining input string data +integer :: inotnull ! count strings not composed of delimiters +integer :: ireturn ! number of tokens returned +integer :: imax ! length of longest token +!----------------------------------------------------------------------------------------------------------------------------------- + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters.ne.'')then ! if DELIMITERS was specified and not null use it + dlim=delimiters + else ! DELIMITERS was specified on call as empty string + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified + endif + else ! no delimiter value was specified + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0)//',:' ! use default delimiter when not specified + endif + idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(order))then; ordr=lower(adjustl(order)); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter + if(present(nulls))then; nlls=lower(adjustl(nulls)); else; nlls='ignore' ; endif ! optional parameter +!----------------------------------------------------------------------------------------------------------------------------------- + n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter + allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:)=1 + iterm(:)=1 +!----------------------------------------------------------------------------------------------------------------------------------- + ilen=len(input_line) ! ILEN is the column position of the last non-blank character + icount=0 ! how many tokens found + inotnull=0 ! how many tokens found not composed of delimiters + imax=0 ! length of longest token found +!----------------------------------------------------------------------------------------------------------------------------------- + select case (ilen) +!----------------------------------------------------------------------------------------------------------------------------------- + case (:0) ! command was totally blank +!----------------------------------------------------------------------------------------------------------------------------------- + case default ! there is at least one non-delimiter in INPUT_LINE if get here + icol=1 ! initialize pointer into input line + INFINITE: do i30=1,ilen,1 ! store into each array element + ibegin(i30)=icol ! assume start new token on the character + if(index(dlim(1:idlim),input_line(icol:icol)).eq.0)then ! if current character is not a delimiter + iterm(i30)=ilen ! initially assume no more tokens + do i10=1,idlim ! search for next delimiter + ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) + IF(ifound.gt.0)then + iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) + endif + enddo + icol=iterm(i30)+2 ! next place to look as found end of this token + inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning + icol=icol+1 ! advance pointer into input string + endif + imax=max(imax,iterm(i30)-ibegin(i30)+1) + icount=i30 ! increment count of number of tokens found + if(icol.gt.ilen)then ! no text left + exit INFINITE + endif + enddo INFINITE +!----------------------------------------------------------------------------------------------------------------------------------- + end select +!----------------------------------------------------------------------------------------------------------------------------------- + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + !allocate(array(ireturn)) ! allocate the array to turn +!----------------------------------------------------------------------------------------------------------------------------------- + select case (trim(adjustl(ordr))) ! decide which order to store tokens + case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first + case default ; ii=1 ; iiii=1 ! first to last + end select +!----------------------------------------------------------------------------------------------------------------------------------- + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20).lt.ibegin(i20))then + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + case default + array(ii)=' ' + ii=ii+iiii + end select + else + array(ii)=input_line(ibegin(i20):iterm(i20)) + ii=ii+iiii + endif + enddo +!----------------------------------------------------------------------------------------------------------------------------------- + end subroutine split +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! replace_str(3f) - [M_CLI2:EDITING] function globally replaces one substring for another in string +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function replace_str(targetline[,old,new|cmd],range,ierr) result (newline) +!! +!! character(len=*) :: targetline +!! character(len=*),intent(in),optional :: old +!! character(len=*),intent(in),optional :: new +!! character(len=*),intent(in),optional :: cmd +!! integer,intent(in),optional :: range(2) +!! integer,intent(out),optional :: ierr +!! logical,intent(in),optional :: clip +!! character(len=:),allocatable :: newline +!!##DESCRIPTION +!! Globally replace one substring for another in string. +!! Either CMD or OLD and NEW must be specified. +!! +!!##OPTIONS +!! targetline input line to be changed +!! old old substring to replace +!! new new substring +!! cmd alternate way to specify old and new string, in +!! the form c/old/new/; where "/" can be any character +!! not in "old" or "new" +!! range if present, only change range(1) to range(2) of occurrences of old string +!! ierr error code. iF ier = -1 bad directive, >= 0 then +!! count of changes made +!! clip whether to return trailing spaces or not. Defaults to .false. +!!##RETURNS +!! newline allocatable string returned +!! +!!##EXAMPLES +!! +!! Sample Program: +!! +!! program demo_replace_str +!! use M_CLI2, only : replace_str +!! implicit none +!! character(len=:),allocatable :: targetline +!! +!! targetline='this is the input string' +!! +!! call testit('th','TH','THis is THe input string') +!! +!! ! a null old substring means "at beginning of line" +!! call testit('','BEFORE:', 'BEFORE:THis is THe input string') +!! +!! ! a null new string deletes occurrences of the old substring +!! call testit('i','', 'BEFORE:THs s THe nput strng') +!! +!! write(*,*)'Examples of the use of RANGE=' +!! +!! targetline=replace_str('a b ab baaa aaaa','a','A') +!! write(*,*)'replace a with A ['//targetline//']' +!! +!! targetline=replace_str('a b ab baaa aaaa','a','A',range=[3,5]) +!! write(*,*)'replace a with A instances 3 to 5 ['//targetline//']' +!! +!! targetline=replace_str('a b ab baaa aaaa','a','',range=[3,5]) +!! write(*,*)'replace a with null instances 3 to 5 ['//targetline//']' +!! +!! targetline=replace_str('a b ab baaa aaaa aa aa a a a aa aaaaaa','aa','CCCC',range=[3,5]) +!! write(*,*)'replace aa with CCCC instances 3 to 5 ['//targetline//']' +!! +!! contains +!! subroutine testit(old,new,expected) +!! character(len=*),intent(in) :: old,new,expected +!! write(*,*)repeat('=',79) +!! write(*,*)':STARTED ['//targetline//']' +!! write(*,*)':OLD['//old//']', ' NEW['//new//']' +!! targetline=replace_str(targetline,old,new) +!! write(*,*)':GOT ['//targetline//']' +!! write(*,*)':EXPECTED['//expected//']' +!! write(*,*)':TEST [',targetline.eq.expected,']' +!! end subroutine testit +!! +!! end program demo_replace_str +!! +!! Expected output +!! +!! =============================================================================== +!! STARTED [this is the input string] +!! OLD[th] NEW[TH] +!! GOT [THis is THe input string] +!! EXPECTED[THis is THe input string] +!! TEST [ T ] +!! =============================================================================== +!! STARTED [THis is THe input string] +!! OLD[] NEW[BEFORE:] +!! GOT [BEFORE:THis is THe input string] +!! EXPECTED[BEFORE:THis is THe input string] +!! TEST [ T ] +!! =============================================================================== +!! STARTED [BEFORE:THis is THe input string] +!! OLD[i] NEW[] +!! GOT [BEFORE:THs s THe nput strng] +!! EXPECTED[BEFORE:THs s THe nput strng] +!! TEST [ T ] +!! Examples of the use of RANGE= +!! replace a with A [A b Ab bAAA AAAA] +!! replace a with A instances 3 to 5 [a b ab bAAA aaaa] +!! replace a with null instances 3 to 5 [a b ab b aaaa] +!! replace aa with CCCC instances 3 to 5 [a b ab baaa aaCCCC CCCC CCCC a a a aa aaaaaa] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine crack_cmd(cmd,old,new,ierr) +!----------------------------------------------------------------------------------------------------------------------------------- +character(len=*),intent(in) :: cmd +character(len=:),allocatable,intent(out) :: old,new ! scratch string buffers +integer :: ierr +!----------------------------------------------------------------------------------------------------------------------------------- +character(len=1) :: delimiters +integer :: itoken +integer,parameter :: id=2 ! expected location of delimiter +logical :: ifok +integer :: lmax ! length of target string +integer :: start_token,end_token +!----------------------------------------------------------------------------------------------------------------------------------- + ierr=0 + old='' + new='' + lmax=len_trim(cmd) ! significant length of change directive + + if(lmax.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 + call journal('sc','*crack_cmd* incorrect change directive -too short') + endif + +end subroutine crack_cmd +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function replace_str(targetline,old,new,ierr,cmd,range) result (newline) + +! ident_21="@(#)M_CLI2::replace_str(3f): Globally replace one substring for another in string" + +!----------------------------------------------------------------------------------------------------------------------------------- +! parameters +character(len=*),intent(in) :: targetline ! input line to be changed +character(len=*),intent(in),optional :: old ! old substring to replace +character(len=*),intent(in),optional :: new ! new substring +integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made +character(len=*),intent(in),optional :: cmd ! contains the instructions changing the string +integer,intent(in),optional :: range(2) ! start and end of which changes to make +!----------------------------------------------------------------------------------------------------------------------------------- +! returns +character(len=:),allocatable :: newline ! output string buffer +!----------------------------------------------------------------------------------------------------------------------------------- +! local +character(len=:),allocatable :: new_local, old_local +integer :: icount,ichange,ier2 +integer :: original_input_length +integer :: len_old, len_new +integer :: ladd +integer :: left_margin, right_margin +integer :: ind +integer :: ic +integer :: 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 + call journal('sc','*replace_str* must specify OLD and NEW or CMD') + return + endif +!----------------------------------------------------------------------------------------------------------------------------------- + icount=0 ! initialize error flag/change count + ichange=0 ! initialize error flag/change count + original_input_length=len_trim(targetline) ! get non-blank length of input line + len_old=len(old_local) ! length of old substring to be replaced + len_new=len(new_local) ! length of new substring to replace old substring + left_margin=1 ! left_margin is left margin of window to change + right_margin=len(targetline) ! right_margin is right margin of window to change + newline='' ! begin with a blank line as output string +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(range))then + range_local=range + else + range_local=[1,original_input_length] + endif +!----------------------------------------------------------------------------------------------------------------------------------- + if(len_old.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.le.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_str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! quote(3f) - [M_CLI2:QUOTES] add quotes to string as if written with list-directed input +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function quote(str,mode,clip) result (quoted_str) +!! +!! character(len=*),intent(in) :: str +!! character(len=*),optional,intent(in) :: mode +!! logical,optional,intent(in) :: clip +!! character(len=:),allocatable :: quoted_str +!!##DESCRIPTION +!! Add quotes to a CHARACTER variable as if it was written using +!! list-directed input. This is particularly useful for processing +!! strings to add to CSV files. +!! +!!##OPTIONS +!! str input string to add quotes to, using the rules of +!! list-directed input (single quotes are replaced by two adjacent quotes) +!! mode alternate quoting methods are supported: +!! +!! DOUBLE default. replace quote with double quotes +!! ESCAPE replace quotes with backslash-quote instead of double quotes +!! +!! clip default is to trim leading and trailing spaces from the string. If CLIP +!! is .FALSE. spaces are not trimmed +!! +!!##RESULT +!! quoted_str The output string, which is based on adding quotes to STR. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_quote +!! use M_CLI2, only : quote +!! implicit none +!! character(len=:),allocatable :: str +!! character(len=1024) :: msg +!! integer :: ios +!! character(len=80) :: inline +!! do +!! write(*,'(a)',advance='no')'Enter test string:' +!! read(*,'(a)',iostat=ios,iomsg=msg)inline +!! if(ios.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 +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function quote(str,mode,clip) result (quoted_str) +character(len=*),intent(in) :: str ! the string to be quoted +character(len=*),optional,intent(in) :: mode +logical,optional,intent(in) :: clip +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_str(quoted_str,'"','""'))//double_quote + case('escape') + quoted_str=double_quote//trim(replace_str(quoted_str,'"','\"'))//double_quote + case default + call journal('sc','*quote* ERROR: unknown quote mode ',local_mode) + quoted_str=str + end select +!----------------------------------------------------------------------------------------------------------------------------------- +end function quote +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! unquote(3f) - [M_CLI2:QUOTES] remove quotes from string as if read with list-directed input +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! function unquote(quoted_str,esc) result (unquoted_str) +!! +!! character(len=*),intent(in) :: quoted_str +!! character(len=1),optional,intent(in) :: esc +!! character(len=:),allocatable :: unquoted_str +!!##DESCRIPTION +!! Remove quotes from a CHARACTER variable as if it was read using +!! list-directed input. This is particularly useful for processing +!! tokens read from input such as CSV files. +!! +!! Fortran can now read using list-directed input from an internal file, +!! which should handle quoted strings, but list-directed input does not +!! support escape characters, which UNQUOTE(3f) does. +!!##OPTIONS +!! quoted_str input string to remove quotes from, using the rules of +!! list-directed input (two adjacent quotes inside a quoted +!! region are replaced by a single quote, a single quote or +!! double quote is selected as the delimiter based on which +!! is encountered first going from left to right, ...) +!! esc optional character used to protect the next quote +!! character from being processed as a quote, but simply as +!! a plain character. +!!##RESULT +!! unquoted_str The output string, which is based on removing quotes from quoted_str. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_unquote +!! use M_CLI2, only : unquote +!! implicit none +!! character(len=128) :: quoted_str +!! character(len=:),allocatable :: unquoted_str +!! character(len=1),parameter :: esc='\' +!! character(len=1024) :: msg +!! integer :: ios +!! character(len=1024) :: dummy +!! do +!! write(*,'(a)',advance='no')'Enter test string:' +!! read(*,'(a)',iostat=ios,iomsg=msg)quoted_str +!! if(ios.ne.0)then +!! write(*,*)trim(msg) +!! exit +!! endif +!! +!! ! the original string +!! write(*,'(a)')'QUOTED ['//trim(quoted_str)//']' +!! +!! ! the string processed by unquote(3f) +!! unquoted_str=unquote(trim(quoted_str),esc) +!! write(*,'(a)')'UNQUOTED ['//unquoted_str//']' +!! +!! ! read the string list-directed to compare the results +!! read(quoted_str,*,iostat=ios,iomsg=msg)dummy +!! if(ios.ne.0)then +!! write(*,*)trim(msg) +!! else +!! write(*,'(a)')'LIST DIRECTED['//trim(dummy)//']' +!! endif +!! enddo +!! end program demo_unquote +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function unquote(quoted_str,esc) result (unquoted_str) +character(len=*),intent(in) :: quoted_str ! the string to be unquoted +character(len=1),optional,intent(in) :: esc ! escape character +character(len=:),allocatable :: unquoted_str +integer :: inlen +character(len=1),parameter :: single_quote = "'" +character(len=1),parameter :: double_quote = '"' +integer :: quote ! whichever quote is to be used +integer :: before +integer :: current +integer :: iesc +integer :: iput +integer :: i +logical :: inside +!----------------------------------------------------------------------------------------------------------------------------------- + if(present(esc))then ! select escape character as specified character or special value meaning not set + iesc=ichar(esc) ! allow for an escape character + else + iesc=-1 ! set to value that matches no character + endif +!----------------------------------------------------------------------------------------------------------------------------------- + inlen=len(quoted_str) ! find length of input string + allocate(character(len=inlen) :: unquoted_str) ! initially make output string length of input string +!----------------------------------------------------------------------------------------------------------------------------------- + if(inlen.ge.1)then ! double_quote is the default quote unless the first character is single_quote + if(quoted_str(1:1).eq.single_quote)then + quote=ichar(single_quote) + else + quote=ichar(double_quote) + endif + else + quote=ichar(double_quote) + endif +!----------------------------------------------------------------------------------------------------------------------------------- + before=-2 ! initially set previous character to impossible value + unquoted_str(:)='' ! initialize output string to null string + iput=1 + inside=.false. + STEPTHROUGH: do i=1,inlen + current=ichar(quoted_str(i:i)) + if(before.eq.iesc)then ! if previous character was escape use current character unconditionally + iput=iput-1 ! backup + unquoted_str(iput:iput)=char(current) + iput=iput+1 + before=-2 ! this could be second esc or quote + elseif(current.eq.quote)then ! if current is a quote it depends on whether previous character was a quote + if(before.eq.quote)then + unquoted_str(iput:iput)=char(quote) ! this is second quote so retain it + iput=iput+1 + before=-2 + elseif(.not.inside.and.before.ne.iesc)then + inside=.true. + else ! this is first quote so ignore it except remember it in case next is a quote + before=current + endif + else + unquoted_str(iput:iput)=char(current) + iput=iput+1 + before=current + endif + enddo STEPTHROUGH +!----------------------------------------------------------------------------------------------------------------------------------- + unquoted_str=unquoted_str(:iput-1) +!----------------------------------------------------------------------------------------------------------------------------------- +end function unquote +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function i2s(ivalue,fmt) result(outstr) + +! ident_22="@(#)M_CLI2::i2s(3fp): private function returns string given integer value" + +integer,intent(in) :: ivalue ! input value to convert to a string +character(len=*),intent(in),optional :: fmt +character(len=:),allocatable :: outstr ! output string to generate +character(len=80) :: string + if(present(fmt))then + call value_to_string(ivalue,string,fmt=fmt) + else + call value_to_string(ivalue,string) + endif + outstr=trim(string) +end function i2s +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! merge_str(3f) - [M_CLI2:LENGTH] pads strings to same length and then calls MERGE(3f) +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function merge_str(str1,str2,expr) result(strout) +!! +!! character(len=*),intent(in),optional :: str1 +!! character(len=*),intent(in),optional :: str2 +!! logical,intent(in) :: expr +!! character(len=:),allocatable :: strout +!!##DESCRIPTION +!! merge_str(3f) pads the shorter of str1 and str2 to the longest length +!! of str1 and str2 and then calls MERGE(padded_str1,padded_str2,expr). +!! It trims trailing spaces off the result and returns the trimmed +!! string. This makes it easier to call MERGE(3f) with strings, as +!! MERGE(3f) requires the strings to be the same length. +!! +!! NOTE: STR1 and STR2 are always required even though declared optional. +!! this is so the call "STR_MERGE(A,B,present(A))" is a valid call. +!! The parameters STR1 and STR2 when they are optional parameters +!! can be passed to a procedure if the options are optional on the +!! called procedure. +!! +!!##OPTIONS +!! STR1 string to return if the logical expression EXPR is true +!! STR2 string to return if the logical expression EXPR is false +!! EXPR logical expression to evaluate to determine whether to return +!! STR1 when true, and STR2 when false. +!!##RESULT +!! MERGE_STR a trimmed string is returned that is otherwise the value +!! of STR1 or STR2, depending on the logical expression EXPR. +!! +!!##EXAMPLES +!! +!! Sample Program: +!! +!! program demo_merge_str +!! use M_CLI2, only : merge_str +!! implicit none +!! character(len=:), allocatable :: answer +!! answer=merge_str('first string', 'second string is longer',10.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] +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function merge_str(str1,str2,expr) result(strout) +! for some reason the MERGE(3f) intrinsic requires the strings it compares to be of equal length +! make an alias for MERGE(3f) that makes the lengths the same before doing the comparison by padding the shorter one with spaces + +! ident_23="@(#)M_CLI2::merge_str(3f): pads first and second arguments to MERGE(3f) to same length" + +character(len=*),intent(in),optional :: str1 +character(len=*),intent(in),optional :: str2 +character(len=:),allocatable :: str1_local +character(len=:),allocatable :: str2_local +logical,intent(in) :: expr +character(len=:),allocatable :: strout +integer :: big + if(present(str2))then + str2_local=str2 + else + str2_local='' + endif + if(present(str1))then + str1_local=str1 + else + str1_local='' + endif + big=max(len(str1_local),len(str2_local)) + ! note: perhaps it would be better to warn or fail if an optional value that is not present is returned, instead of returning '' + strout=trim(merge(lenset(str1_local,big),lenset(str2_local,big),expr)) +end function merge_str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! +!! decodebase(3f) - [M_CLI2:BASE] convert whole number string in base [2-36] to base 10 number +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! logical function decodebase(string,basein,out10) +!! +!! character(len=*),intent(in) :: string +!! integer,intent(in) :: basein +!! integer,intent(out) :: out10 +!!##DESCRIPTION +!! +!! Convert a numeric string representing a whole number in base BASEIN +!! to base 10. The function returns FALSE if BASEIN is not in the range +!! [2..36] or if string STRING contains invalid characters in base BASEIN +!! or if result OUT10 is too big +!! +!! The letters A,B,...,Z represent 10,11,...,36 in the base > 10. +!! +!!##OPTIONS +!! string input string. It represents a whole number in +!! the base specified by BASEIN unless BASEIN is set +!! to zero. When BASEIN is zero STRING is assumed to +!! be of the form BASE#VALUE where BASE represents +!! the function normally provided by BASEIN. +!! basein base of input string; either 0 or from 2 to 36. +!! out10 output value in base 10 +!! +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_decodebase +!! use M_CLI2, only : codebase, decodebase +!! implicit none +!! integer :: ba,bd +!! character(len=40) :: x,y +!! integer :: r +!! +!! print *,' BASE CONVERSION' +!! write(*,'("Start Base (2 to 36): ")',advance='no'); read *, bd +!! write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba +!! INFINITE: do +!! print *,'' +!! write(*,'("Enter number in start base: ")',advance='no'); read *, x +!! if(x.eq.'0') exit INFINITE +!! if(decodebase(x,bd,r)) then +!! if(codebase(r,ba,y)) then +!! write(*,'("In base ",I2,": ",A20)') ba, y +!! else +!! print *,'Error in coding number.' +!! endif +!! else +!! print *,'Error in decoding number.' +!! endif +!! enddo INFINITE +!! +!! end program demo_decodebase +!! +!!##AUTHOR +!! John S. Urban +!! +!! Ref.: "Math matiques en Turbo-Pascal by +!! M. Ducamp and A. Reverchon (2), +!! Eyrolles, Paris, 1988". +!! +!! based on a F90 Version By J-P Moreau (www.jpmoreau.fr) +!! +!!##LICENSE +!! Public Domain +logical function decodebase(string,basein,out_baseten) +implicit none + +! ident_24="@(#)M_CLI2::decodebase(3f): convert whole number string in base [2-36] to base 10 number" + +character(len=*),intent(in) :: string +integer,intent(in) :: basein +integer,intent(out) :: out_baseten + +character(len=len(string)) :: string_local +integer :: long, i, j, k +real :: y +real :: mult +character(len=1) :: ch +real,parameter :: XMAXREAL=real(huge(1)) +integer :: out_sign +integer :: basein_local +integer :: ipound +integer :: ierr + + string_local=upper(trim(adjustl(string))) + decodebase=.false. + + ipound=index(string_local,'#') ! determine if in form [-]base#whole + if(basein.eq.0.and.ipound.gt.1)then ! split string into two values + call a2i(string_local(:ipound-1),basein_local,ierr) ! get the decimal value of the base + string_local=string_local(ipound+1:) ! now that base is known make string just the value + if(basein_local.ge.0)then ! allow for a negative sign prefix + out_sign=1 + else + out_sign=-1 + endif + basein_local=abs(basein_local) + else ! assume string is a simple positive value + basein_local=abs(basein) + out_sign=1 + endif + + out_baseten=0 + y=0.0 + ALL: if(basein_local<2.or.basein_local>36) then + print *,'(*decodebase* ERROR: Base must be between 2 and 36. base=',basein_local + else ALL + out_baseten=0;y=0.0; mult=1.0 + long=LEN_TRIM(string_local) + do i=1, long + k=long+1-i + ch=string_local(k:k) + if(ch.eq.'-'.and.k.eq.1)then + out_sign=-1 + cycle + endif + if(ch<'0'.or.ch>'Z'.or.(ch>'9'.and.ch<'A'))then + write(*,*)'*decodebase* ERROR: invalid character ',ch + exit ALL + endif + if(ch<='9') then + j=IACHAR(ch)-IACHAR('0') + else + j=IACHAR(ch)-IACHAR('A')+10 + endif + if(j>=basein_local)then + exit ALL + endif + y=y+mult*j + if(mult>XMAXREAL/basein_local)then + exit ALL + endif + mult=mult*basein_local + enddo + decodebase=.true. + out_baseten=nint(out_sign*y)*sign(1,basein) + endif ALL +end function decodebase +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! lenset(3f) - [M_CLI2:LENGTH] return string trimmed or padded to specified length +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! function lenset(str,length) result(strout) +!! +!! character(len=*) :: str +!! character(len=length) :: strout +!! integer,intent(in) :: length +!!##DESCRIPTION +!! lenset(3f) truncates a string or pads it with spaces to the specified +!! length. +!!##OPTIONS +!! str input string +!! length output string length +!!##RESULTS +!! strout output string +!!##EXAMPLE +!! +!! Sample Program: +!! +!! program demo_lenset +!! use M_CLI2, only : lenset +!! implicit none +!! character(len=10) :: string='abcdefghij' +!! character(len=:),allocatable :: answer +!! answer=lenset(string,5) +!! write(*,'("[",a,"]")') answer +!! answer=lenset(string,20) +!! write(*,'("[",a,"]")') answer +!! end program demo_lenset +!! +!! Expected output: +!! +!! [abcde] +!! [abcdefghij ] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function lenset(line,length) result(strout) + +! ident_25="@(#)M_CLI2::lenset(3f): return string trimmed or padded to specified length" + +character(len=*),intent(in) :: line +integer,intent(in) :: length +character(len=length) :: strout + strout=line +end function lenset +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! value_to_string(3f) - [M_CLI2:NUMERIC] return numeric string from a numeric value +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine value_to_string(value,chars[,ilen,ierr,fmt,trimz]) +!! +!! character(len=*) :: chars ! minimum of 23 characters required +!! !-------- +!! ! VALUE may be any one of the following types: +!! doubleprecision,intent(in) :: value +!! real,intent(in) :: value +!! integer,intent(in) :: value +!! logical,intent(in) :: value +!! !-------- +!! character(len=*),intent(out) :: chars +!! integer,intent(out),optional :: ilen +!! integer,optional :: ierr +!! character(len=*),intent(in),optional :: fmt +!! logical,intent(in) :: trimz +!! +!!##DESCRIPTION +!! value_to_string(3f) returns a numeric representation of a numeric +!! value in a string given a numeric value of type REAL, DOUBLEPRECISION, +!! INTEGER or LOGICAL. It creates the string using internal writes. It +!! then removes trailing zeros from non-zero values, and left-justifies +!! the string. +!! +!!##OPTIONS +!! VALUE input value to be converted to a string +!! FMT You may specify a specific format that produces a string +!! up to the length of CHARS; optional. +!! TRIMZ If a format is supplied the default is not to try to trim +!! trailing zeros. Set TRIMZ to .true. to trim zeros from a +!! string assumed to represent a simple numeric value. +!! +!!##RETURNS +!! CHARS returned string representing input value, must be at least +!! 23 characters long; or what is required by optional FMT if longer. +!! ILEN position of last non-blank character in returned string; optional. +!! IERR If not zero, error occurred; optional. +!!##EXAMPLE +!! +!! Sample program: +!! +!! program demo_value_to_string +!! use M_CLI2, only: value_to_string +!! implicit none +!! character(len=80) :: string +!! integer :: ilen +!! call value_to_string(3.0/4.0,string,ilen) +!! write(*,*) 'The value is [',string(:ilen),']' +!! +!! call value_to_string(3.0/4.0,string,ilen,fmt='') +!! write(*,*) 'The value is [',string(:ilen),']' +!! +!! call value_to_string(3.0/4.0,string,ilen,fmt='("THE VALUE IS ",g0)') +!! write(*,*) 'The value is [',string(:ilen),']' +!! +!! call value_to_string(1234,string,ilen) +!! write(*,*) 'The value is [',string(:ilen),']' +!! +!! call value_to_string(1.0d0/3.0d0,string,ilen) +!! write(*,*) 'The value is [',string(:ilen),']' +!! +!! end program demo_value_to_string +!! +!! Expected output +!! +!! The value is [0.75] +!! The value is [ 0.7500000000] +!! The value is [THE VALUE IS .750000000] +!! The value is [1234] +!! The value is [0.33333333333333331] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine value_to_string(gval,chars,length,err,fmt,trimz) + +! ident_26="@(#)M_CLI2::value_to_string(3fp): subroutine returns a string from a value" + +class(*),intent(in) :: gval +character(len=*),intent(out) :: chars +integer,intent(out),optional :: length +integer,optional :: err +integer :: err_local +character(len=*),optional,intent(in) :: fmt ! format to write value with +logical,intent(in),optional :: trimz +character(len=:),allocatable :: fmt_local +character(len=1024) :: msg + +! Notice that the value GVAL can be any of several types ( INTEGER,REAL,DOUBLEPRECISION,LOGICAL) + + if (present(fmt)) then + select type(gval) + type is (integer) + fmt_local='(i0)' + if(fmt.ne.'') fmt_local=fmt + write(chars,fmt_local,iostat=err_local,iomsg=msg)gval + type is (real) + fmt_local='(bz,g23.10e3)' + fmt_local='(bz,g0.8)' + if(fmt.ne.'') fmt_local=fmt + write(chars,fmt_local,iostat=err_local,iomsg=msg)gval + type is (doubleprecision) + fmt_local='(bz,g0)' + if(fmt.ne.'') fmt_local=fmt + write(chars,fmt_local,iostat=err_local,iomsg=msg)gval + type is (logical) + fmt_local='(l1)' + if(fmt.ne.'') fmt_local=fmt + write(chars,fmt_local,iostat=err_local,iomsg=msg)gval + class default + call journal('sc','*value_to_string* UNKNOWN TYPE') + chars=' ' + end select + if(fmt.eq.'') then + chars=adjustl(chars) + call trimzeros_(chars) + endif + else ! no explicit format option present + err_local=-1 + select type(gval) + type is (integer) + write(chars,*,iostat=err_local,iomsg=msg)gval + type is (real) + write(chars,*,iostat=err_local,iomsg=msg)gval + type is (doubleprecision) + write(chars,*,iostat=err_local,iomsg=msg)gval + type is (logical) + write(chars,*,iostat=err_local,iomsg=msg)gval + class default + chars='' + end select + chars=adjustl(chars) + if(index(chars,'.').ne.0) call trimzeros_(chars) + endif + if(present(trimz))then + if(trimz)then + chars=adjustl(chars) + call trimzeros_(chars) + endif + endif + + if(present(length)) then + length=len_trim(chars) + endif + + if(present(err)) then + err=err_local + elseif(err_local.ne.0)then + !-! cannot currently do I/O from a function being called from I/O + !-!write(ERROR_UNIT,'(a)')'*value_to_string* WARNING:['//trim(msg)//']' + chars=chars//' *value_to_string* WARNING:['//trim(msg)//']' + endif + +end subroutine value_to_string +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! trimzeros_(3fp) - [M_CLI2:NUMERIC] Delete trailing zeros from numeric decimal string +!! (LICENSE:PD) +!!##SYNOPSIS +!! +!! subroutine trimzeros_(str) +!! +!! character(len=*) :: str +!!##DESCRIPTION +!! TRIMZEROS_(3f) deletes trailing zeros from a string representing a +!! number. If the resulting string would end in a decimal point, one +!! trailing zero is added. +!!##OPTIONS +!! str input string will be assumed to be a numeric value and have trailing +!! zeros removed +!!##EXAMPLES +!! +!! Sample program: +!! +!! program demo_trimzeros_ +!! use M_CLI2, only : trimzeros_ +!! character(len=:),allocatable :: string +!! write(*,*)trimzeros_('123.450000000000') +!! write(*,*)trimzeros_('12345') +!! write(*,*)trimzeros_('12345.') +!! write(*,*)trimzeros_('12345.00e3') +!! end program demo_trimzeros_ +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine trimzeros_(string) + +! ident_27="@(#)M_CLI2::trimzeros_(3fp): Delete trailing zeros from numeric decimal string" + +! if zero needs added at end assumes input string has room +character(len=*) :: string +character(len=len(string)+2) :: str +character(len=len(string)) :: exp ! the exponent string if present +integer :: ipos ! where exponent letter appears if present +integer :: i, ii + str=string ! working copy of string + ipos=scan(str,'eEdD') ! find end of real number if string uses exponent notation + if(ipos>0) then ! letter was found + exp=str(ipos:) ! keep exponent string so it can be added back as a suffix + str=str(1:ipos-1) ! just the real part, exponent removed will not have trailing zeros removed + endif + if(index(str,'.').eq.0)then ! if no decimal character in original string add one to end of string + ii=len_trim(str) + str(ii+1:ii+1)='.' ! add decimal to end of string + endif + do i=len_trim(str),1,-1 ! scanning from end find a non-zero character + select case(str(i:i)) + case('0') ! found a trailing zero so keep trimming + cycle + case('.') ! found a decimal character at end of remaining string + if(i.le.1)then + str='0' + else + str=str(1:i-1) + endif + exit + case default + str=str(1:i) ! found a non-zero character so trim string and exit + exit + end select + end do + if(ipos>0)then ! if originally had an exponent place it back on + string=trim(str)//trim(exp) + else + string=str + endif +end subroutine trimzeros_ +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! substitute(3f) - [M_CLI2:EDITING] subroutine globally substitutes one substring for another in string +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine substitute(targetline,old,new,ierr,start,end) +!! +!! character(len=*) :: targetline +!! character(len=*),intent(in) :: old +!! character(len=*),intent(in) :: new +!! integer,intent(out),optional :: ierr +!! integer,intent(in),optional :: start +!! integer,intent(in),optional :: end +!!##DESCRIPTION +!! Globally substitute one substring for another in string. +!! +!!##OPTIONS +!! TARGETLINE input line to be changed. Must be long enough to +!! hold altered output. +!! OLD substring to find and replace +!! NEW replacement for OLD substring +!! IERR error code. If IER = -1 bad directive, >= 0 then +!! count of changes made. +!! START sets the left margin to be scanned for OLD in +!! TARGETLINE. +!! END sets the right margin to be scanned for OLD in +!! TARGETLINE. +!! +!!##EXAMPLES +!! +!! Sample Program: +!! +!! program demo_substitute +!! use M_CLI2, only : substitute +!! implicit none +!! ! must be long enough to hold changed line +!! character(len=80) :: targetline +!! +!! targetline='this is the input string' +!! write(*,*)'ORIGINAL : '//trim(targetline) +!! +!! ! changes the input to 'THis is THe input string' +!! call substitute(targetline,'th','TH') +!! write(*,*)'th => TH : '//trim(targetline) +!! +!! ! a null old substring means "at beginning of line" +!! ! changes the input to 'BEFORE:this is the input string' +!! call substitute(targetline,'','BEFORE:') +!! write(*,*)'"" => BEFORE: '//trim(targetline) +!! +!! ! a null new string deletes occurrences of the old substring +!! ! changes the input to 'ths s the nput strng' +!! call substitute(targetline,'i','') +!! write(*,*)'i => "" : '//trim(targetline) +!! +!! end program demo_substitute +!! +!! Expected output +!! +!! ORIGINAL : this is the input string +!! th => TH : THis is THe input string +!! "" => BEFORE: BEFORE:THis is THe input string +!! i => "" : BEFORE:THs s THe nput strng +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine substitute(targetline,old,new,ierr,start,end) + +! ident_28="@(#)M_CLI2::substitute(3f): Globally substitute one substring for another in string" + +!----------------------------------------------------------------------------------------------------------------------------------- +character(len=*) :: targetline ! input line to be changed +character(len=*),intent(in) :: old ! old substring to replace +character(len=*),intent(in) :: new ! new substring +integer,intent(out),optional :: ierr ! error code. if ierr = -1 bad directive, >=0 then ierr changes made +integer,intent(in),optional :: start ! start sets the left margin +integer,intent(in),optional :: end ! end sets the right margin +!----------------------------------------------------------------------------------------------------------------------------------- +character(len=len(targetline)) :: dum1 ! scratch string buffers +integer :: ml, mr, ier1 +integer :: maxlengthout ! MAXIMUM LENGTH ALLOWED FOR NEW STRING +integer :: original_input_length +integer :: len_old, len_new +integer :: ladd +integer :: ir +integer :: ind +integer :: il +integer :: id +integer :: ic +integer :: ichar +!----------------------------------------------------------------------------------------------------------------------------------- + if (present(start)) then ! optional starting column + ml=start + else + ml=1 + endif + if (present(end)) then ! optional ending column + mr=end + else + mr=len(targetline) + endif +!----------------------------------------------------------------------------------------------------------------------------------- + ier1=0 ! initialize error flag/change count + maxlengthout=len(targetline) ! max length of output string + original_input_length=len_trim(targetline) ! get non-blank length of input line + dum1(:)=' ' ! initialize string to build output in + id=mr-ml ! check for window option !-! change to optional parameter(s) +!----------------------------------------------------------------------------------------------------------------------------------- + len_old=len(old) ! length of old substring to be replaced + len_new=len(new) ! length of new substring to replace old substring + if(id.le.0)then ! no window so change entire input string + il=1 ! il is left margin of window to change + ir=maxlengthout ! ir is right margin of window to change + dum1(:)=' ' ! begin with a blank line + else ! if window is set + il=ml ! use left margin + ir=min0(mr,maxlengthout) ! use right margin or rightmost + dum1=targetline(:il-1) ! begin with what's below margin + endif ! end of window settings +!----------------------------------------------------------------------------------------------------------------------------------- + if(len_old.eq.0)then ! c//new/ means insert new at beginning of line (or left margin) + ichar=len_new + original_input_length + if(ichar.gt.maxlengthout)then + call journal('sc','*substitute* new line will be too long') + ier1=-1 + if (present(ierr))ierr=ier1 + return + endif + if(len_new.gt.0)then + dum1(il:)=new(:len_new)//targetline(il:original_input_length) + else + dum1(il:)=targetline(il:original_input_length) + endif + targetline(1:maxlengthout)=dum1(:maxlengthout) + ier1=1 ! made one change. actually, c/// should maybe return 0 + if(present(ierr))ierr=ier1 + return + endif +!----------------------------------------------------------------------------------------------------------------------------------- + ichar=il ! place to put characters into output string + ic=il ! place looking at in input string + loop: do + ind=index(targetline(ic:),old(:len_old))+ic-1 ! try to find start of old string in remaining part of input in change window + if(ind.eq.ic-1.or.ind.gt.ir)then ! did not find old string or found old string past edit window + exit loop ! no more changes left to make + endif + ier1=ier1+1 ! found an old string to change, so increment count of changes + if(ind.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 + if(ichar-1+ladd.gt.maxlengthout)then + ier1=-1 + exit loop + endif + dum1(ichar:)=targetline(ic:ind-1) + ichar=ichar+ladd + endif + if(ichar-1+len_new.gt.maxlengthout)then + ier1=-2 + exit loop + endif + if(len_new.ne.0)then + dum1(ichar:)=new(:len_new) + ichar=ichar+len_new + endif + ic=ind+len_old + enddo loop +!----------------------------------------------------------------------------------------------------------------------------------- + select case (ier1) + case (:-1) + call journal('sc','*substitute* new line will be too long') + case (0) ! there were no changes made to the window + case default + ladd=original_input_length-ic + if(ichar+ladd.gt.maxlengthout)then + call journal('sc','*substitute* new line will be too long') + ier1=-1 + if(present(ierr))ierr=ier1 + return + endif + if(ic.lt.len(targetline))then + dum1(ichar:)=targetline(ic:max(ic,original_input_length)) + endif + targetline=dum1(:maxlengthout) + end select + if(present(ierr))ierr=ier1 +!----------------------------------------------------------------------------------------------------------------------------------- +end subroutine substitute +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! locate(3f) - [M_CLI2] finds the index where a string is found or should be in a sorted array +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine locate(list,value,place,ier,errmsg) +!! +!! character(len=:)|doubleprecision|real|integer,allocatable :: list(:) +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! integer, intent(out) :: PLACE +!! +!! integer, intent(out),optional :: IER +!! character(len=*),intent(out),optional :: ERRMSG +!! +!!##DESCRIPTION +!! +!! LOCATE(3f) finds the index where the VALUE is found or should +!! be found in an array. The array must be sorted in descending +!! order (highest at top). If VALUE is not found it returns the index +!! where the name should be placed at with a negative sign. +!! +!! The array and list must be of the same type (CHARACTER, DOUBLEPRECISION, +!! REAL,INTEGER) +!! +!!##OPTIONS +!! +!! VALUE the value to locate in the list. +!! LIST is the list array. +!! +!!##RETURNS +!! PLACE is the subscript that the entry was found at if it is +!! greater than zero(0). +!! +!! If PLACE is negative, the absolute value of +!! PLACE indicates the subscript value where the +!! new entry should be placed in order to keep the +!! list alphabetized. +!! +!! IER is zero(0) if no error occurs. +!! If an error occurs and IER is not +!! present, the program is stopped. +!! +!! ERRMSG description of any error +!! +!!##EXAMPLES +!! +!! +!! Find if a string is in a sorted array, and insert the string into +!! the list if it is not present ... +!! +!! program demo_locate +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! +!! call update(arr,'b') +!! call update(arr,'[') +!! call update(arr,'c') +!! call update(arr,'ZZ') +!! call update(arr,'ZZZZ') +!! call update(arr,'z') +!! +!! contains +!! subroutine update(arr,string) +!! character(len=:),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 +!!##LICENSE +!! Public Domain +subroutine locate_c(list,value,place,ier,errmsg) + +! ident_29="@(#)M_CLI2::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 + call mystop(1) + endif + if(present(errmsg))then + errmsg=message + endif +end subroutine locate_c +subroutine locate_d(list,value,place,ier,errmsg) + +! ident_30="@(#)M_CLI2::locate_d(3f): find PLACE in sorted doubleprecision array where VALUE can be found or should be placed" + +! Assuming an array sorted in descending order +! +! 1. If it is not found report where it should be placed as a NEGATIVE index number. + +doubleprecision,allocatable :: list(:) +doubleprecision,intent(in) :: value +integer,intent(out) :: place +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=[doubleprecision :: ] + 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=',value,' PLACE=',place + call mystop(1) + endif + if(present(errmsg))then + errmsg=message + endif +end subroutine locate_d +subroutine locate_r(list,value,place,ier,errmsg) + +! ident_31="@(#)M_CLI2::locate_r(3f): find PLACE in sorted real array where VALUE can be found or should be placed" + +! Assuming an array sorted in descending order +! +! 1. If it is not found report where it should be placed as a NEGATIVE index number. + +real,allocatable :: list(:) +real,intent(in) :: value +integer,intent(out) :: place +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=[real :: ] + 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=',value,' PLACE=',place + call mystop(1) + endif + if(present(errmsg))then + errmsg=message + endif +end subroutine locate_r +subroutine locate_i(list,value,place,ier,errmsg) + +! ident_32="@(#)M_CLI2::locate_i(3f): find PLACE in sorted integer array where VALUE can be found or should be placed" + +! Assuming an array sorted in descending order +! +! 1. If it is not found report where it should be placed as a NEGATIVE index number. + +integer,allocatable :: list(:) +integer,intent(in) :: value +integer,intent(out) :: place +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=[integer :: ] + 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=',value,' PLACE=',place + call mystop(1) + endif + if(present(errmsg))then + errmsg=message + endif +end subroutine locate_i +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! remove(3f) - [M_CLI2] remove entry from an allocatable array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine remove(list,place) +!! +!! character(len=:)|doubleprecision|real|integer,intent(inout) :: list(:) +!! integer, intent(out) :: PLACE +!! +!!##DESCRIPTION +!! +!! Remove a value from an allocatable array at the specified index. +!! The array is assumed to be sorted in descending order. It may be of +!! type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER. +!! +!!##OPTIONS +!! +!! list is the list array. +!! PLACE is the subscript for the entry that should be removed +!! +!!##EXAMPLES +!! +!! +!! Sample program +!! +!! program demo_remove +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate, remove +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! integer :: end +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'Z', 'aaa', 'b', 'b', 'ab', 'bb', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! call remove(arr,1) +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! call remove(arr,4) +!! end=size(arr) +!! write(*,'("SIZE=",i0,1x,*(a,","))')end,(trim(arr(i)),i=1,end) +!! +!! end program demo_remove +!! +!! Results: +!! +!! Expected output +!! +!! SIZE=9 xxx,bb,b,b,ab,aaa,ZZZ,Z,, +!! SIZE=8 bb,b,b,ab,aaa,ZZZ,Z,, +!! SIZE=7 bb,b,b,aaa,ZZZ,Z,, +!! +!!##AUTHOR +!! 1989,2017 John S. Urban +!!##LICENSE +!! Public Domain +subroutine remove_c(list,place) + +! ident_33="@(#)M_CLI2::remove_c(3fp): remove string from allocatable string array at specified position" + +character(len=:),allocatable :: list(:) +integer,intent(in) :: place +integer :: ii, end + if(.not.allocated(list))then + list=[character(len=2) :: ] + endif + ii=len(list) + end=size(list) + if(place.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_d(list,place) + +! ident_34="@(#)M_CLI2::remove_d(3fp): remove doubleprecision value from allocatable array at specified position" + +doubleprecision,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[doubleprecision :: ] + 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_d +subroutine remove_r(list,place) + +! ident_35="@(#)M_CLI2::remove_r(3fp): remove value from allocatable array at specified position" + +real,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[real :: ] + 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_r +subroutine remove_l(list,place) + +! ident_36="@(#)M_CLI2::remove_l(3fp): remove value from allocatable array at specified position" + +logical,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(place.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) + +! ident_37="@(#)M_CLI2::remove_i(3fp): remove value from allocatable array at specified position" +integer,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(place.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_CLI2] replace entry in a string array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine replace(list,value,place) +!! +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) +!! integer, intent(out) :: PLACE +!! +!!##DESCRIPTION +!! +!! replace a value in an allocatable array at the specified index. Unless the +!! array needs the string length to increase this is merely an assign of a value +!! to an array element. +!! +!! The array may be of type CHARACTER, DOUBLEPRECISION, REAL, or INTEGER> +!! It is assumed to be sorted in descending order without duplicate values. +!! +!! The value and list must be of the same type. +!! +!!##OPTIONS +!! +!! VALUE the value to place in the array +!! LIST is the array. +!! PLACE is the subscript that the entry should be placed at +!! +!!##EXAMPLES +!! +!! +!! Replace key-value pairs in a dictionary +!! +!! program demo_replace +!! use M_CLI2, only : insert, locate, replace +!! ! Find if a key is in a list and insert it +!! ! into the key list and value list if it is not present +!! ! or replace the associated value if the key existed +!! implicit none +!! character(len=20) :: key +!! character(len=100) :: val +!! character(len=:),allocatable :: keywords(:) +!! character(len=:),allocatable :: values(:) +!! integer :: i +!! integer :: place +!! call update('b','value of b') +!! call update('a','value of a') +!! call update('c','value of c') +!! call update('c','value of c again') +!! call update('d','value of d') +!! call update('a','value of a again') +!! ! show array +!! write(*,'(*(a,"==>",a,/))')(trim(keywords(i)),trim(values(i)),i=1,size(keywords)) +!! +!! call locate(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 +!!##LICENSE +!! Public Domain +subroutine replace_c(list,value,place) + +! ident_38="@(#)M_CLI2::replace_c(3fp): replace string in allocatable string array at specified position" + +character(len=*),intent(in) :: value +character(len=:),allocatable :: list(:) +character(len=:),allocatable :: kludge(:) +integer,intent(in) :: place +integer :: ii +integer :: tlen +integer :: end + if(.not.allocated(list))then + list=[character(len=max(len_trim(value),2)) :: ] + endif + tlen=len_trim(value) + end=size(list) + if(place.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_d(list,value,place) + +! ident_39="@(#)M_CLI2::replace_d(3fp): place doubleprecision value into allocatable array at specified position" + +doubleprecision,intent(in) :: value +doubleprecision,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[doubleprecision :: ] + 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_d* error: index out of range. end=',end,' index=',place + endif +end subroutine replace_d +subroutine replace_r(list,value,place) + +! ident_40="@(#)M_CLI2::replace_r(3fp): place value into allocatable array at specified position" + +real,intent(in) :: value +real,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[real :: ] + 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_r* error: index out of range. end=',end,' index=',place + endif +end subroutine replace_r +subroutine replace_l(list,value,place) + +! ident_41="@(#)M_CLI2::replace_l(3fp): place value into allocatable array at specified position" + +logical,allocatable :: list(:) +logical,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(end.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) + +! ident_42="@(#)M_CLI2::replace_i(3fp): place value into allocatable array at specified position" + +integer,intent(in) :: value +integer,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(end.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_CLI2] insert entry into a string array at specified position +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine insert(list,value,place) +!! +!! character(len=*)|doubleprecision|real|integer,intent(in) :: value +!! character(len=:)|doubleprecision|real|integer,intent(in) :: list(:) +!! integer,intent(in) :: place +!! +!!##DESCRIPTION +!! +!! Insert a value into an allocatable array at the specified index. +!! The list and value must be of the same type (CHARACTER, DOUBLEPRECISION, +!! REAL, or INTEGER) +!! +!!##OPTIONS +!! +!! list is the list array. Must be sorted in descending order. +!! value the value to place in the array +!! PLACE is the subscript that the entry should be placed at +!! +!!##EXAMPLES +!! +!! +!! Find if a string is in a sorted array, and insert the string into +!! the list if it is not present ... +!! +!! program demo_insert +!! use M_sort, only : sort_shell +!! use M_CLI2, only : locate, insert +!! implicit none +!! character(len=:),allocatable :: arr(:) +!! integer :: i +!! +!! arr=[character(len=20) :: '', 'ZZZ', 'aaa', 'b', 'xxx' ] +!! ! make sure sorted in descending order +!! call sort_shell(arr,order='d') +!! ! add or replace values +!! call update(arr,'b') +!! call update(arr,'[') +!! call update(arr,'c') +!! call update(arr,'ZZ') +!! call update(arr,'ZZZ') +!! call update(arr,'ZZZZ') +!! call update(arr,'') +!! call update(arr,'z') +!! +!! contains +!! subroutine update(arr,string) +!! character(len=:),allocatable :: arr(:) +!! character(len=*) :: string +!! integer :: place, end +!! +!! end=size(arr) +!! ! find where string is or should be +!! call locate(arr,string,place) +!! ! if string was not found insert it +!! if(place.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 +!!##LICENSE +!! Public Domain +subroutine insert_c(list,value,place) + +! ident_43="@(#)M_CLI2::insert_c(3fp): place string into allocatable string array at specified position" + +character(len=*),intent(in) :: value +character(len=:),allocatable :: list(:) +character(len=:),allocatable :: kludge(:) +integer,intent(in) :: place +integer :: ii +integer :: end + + if(.not.allocated(list))then + list=[character(len=max(len_trim(value),2)) :: ] + endif + + ii=max(len_trim(value),len(list),2) + end=size(list) + + if(end.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_r(list,value,place) + +! ident_44="@(#)M_CLI2::insert_r(3fp): place real value into allocatable array at specified position" + +real,intent(in) :: value +real,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + + if(.not.allocated(list))then + list=[real :: ] + 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_r* error: index out of range. end=',end,' index=',place,' value=',value + endif + +end subroutine insert_r +subroutine insert_d(list,value,place) + +! ident_45="@(#)M_CLI2::insert_d(3fp): place doubleprecision value into allocatable array at specified position" + +doubleprecision,intent(in) :: value +doubleprecision,allocatable :: list(:) +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[doubleprecision :: ] + 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_d* error: index out of range. end=',end,' index=',place,' value=',value + endif +end subroutine insert_d +subroutine insert_l(list,value,place) + +! ident_46="@(#)M_CLI2::insert_l(3fp): place value into allocatable array at specified position" + +logical,allocatable :: list(:) +logical,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[logical :: ] + endif + end=size(list) + if(end.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) + +! ident_47="@(#)M_CLI2::insert_i(3fp): place value into allocatable array at specified position" + +integer,allocatable :: list(:) +integer,intent(in) :: value +integer,intent(in) :: place +integer :: end + if(.not.allocated(list))then + list=[integer :: ] + endif + end=size(list) + if(end.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 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! dict_delete(3f) - [M_CLI2] delete entry by name from an allocatable sorted string array if it is present +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine dict_delete(key,dict) +!! +!! character(len=*),intent(in) :: key +!! type(dictionary) :: dict +!! +!!##DESCRIPTION +!! +!! Find if a string is in a sorted array, and delete the string +!! from the dictionary if it is present. +!! +!!##OPTIONS +!! +!! KEY the key name to find and delete from the dictionary. +!! DICTIONARY the dictionary. +!! +!!##EXAMPLES +!! +!! +!! delete a key from a dictionary by name. +!! +!! program demo_dict_delete +!! use M_CLI2, only : dictionary +!! implicit none +!! type(dictionary) :: caps +!! integer :: i +!! call caps%set(caps,'A','aye') +!! call caps%set(caps,'B','bee') +!! call caps%set(caps,'C','see') +!! call caps%set(caps,'D','dee') +!! +!! write(*,101)(trim(arr(i)),i=1,size(caps%keys)) ! show array +!! call caps%del(caps,'A') +!! call caps%del(caps,'C') +!! call caps%del(caps,'z') +!! write(*,101)(trim(arr(i)),i=1,size(arr)) ! show array +!! 101 format (1x,*("[",a,"]",:,",")) +!! end program demo_dict_delete +!! +!! Results: +!! +!! [z],[xxx],[c],[b],[b],[aaa],[ZZZ],[ZZ] +!! [z],[xxx],[b],[b],[aaa],[ZZZ],[ZZ] +!! [z],[xxx],[b],[b],[aaa],[ZZZ],[ZZ] +!! [z],[xxx],[b],[b],[aaa],[ZZZ],[ZZ] +!! [z],[xxx],[aaa],[ZZZ],[ZZ] +!! [z],[xxx],[aaa],[ZZZ] +!! [z],[xxx],[aaa],[ZZZ] +!! [xxx],[aaa],[ZZZ] +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine dict_delete(self,key) + +! ident_48="@(#)M_CLI2::dict_delete(3f): remove string from sorted allocatable string array if present" + +class(dictionary),intent(inout) :: self +character(len=*),intent(in) :: key +integer :: place + + call locate(self%key,key,place) + if(place.ge.1)then + call remove(self%key,place) + call remove(self%value,place) + call remove(self%count,place) + endif + +end subroutine dict_delete +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! dict_get(3f) - [M_CLI2] get value of key-value pair in a dictionary given key +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine dict_get(dict,key,value) +!! +!! type(dictionary) :: dict +!! character(len=*),intent(in) :: key +!! character(len=*),intent(in) :: VALUE +!! +!!##DESCRIPTION +!! +!! get a value given a key from a key-value dictionary +!! +!! If key is not found in dictionary , return a blank +!! +!!##OPTIONS +!! +!! DICT is the dictionary. +!! KEY key name +!! VALUE value associated with key +!! +!!##EXAMPLES +!! +!! +!! Sample program +!! +!! program demo_locate +!! use M_CLI2, only : dictionary +!! implicit none +!! type(dictionary) :: table +!! integer :: i +!! +!! call table%set('A','value for A') +!! call table%set('B','value for B') +!! call table%set('C','value for C') +!! call table%set('D','value for D') +!! call table%set('E','value for E') +!! call table%set('F','value for F') +!! call table%set('G','value for G') +!! write(*,*)table%get('A') +!! write(*,*)table%get('B') +!! write(*,*)table%get('C') +!! write(*,*)table%get('D') +!! write(*,*)table%get('E') +!! write(*,*)table%get('F') +!! write(*,*)table%get('G') +!! write(*,*)table%get('H') +!! end program demo_locate +!! +!! Results: +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +function dict_get(self,key) result(value) + +! ident_49="@(#)M_CLI2::dict_get(3f): get value of key-value pair in dictionary, given key" + +!-!class(dictionary),intent(inout) :: self +class(dictionary) :: self +character(len=*),intent(in) :: key +character(len=:),allocatable :: value +integer :: place + call locate(self%key,key,place) + if(place.lt.1)then + value='' + else + value=self%value(place)(:self%count(place)) + endif +end function dict_get +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +!> +!!##NAME +!! dict_add(3f) - [M_CLI2] add or replace a key-value pair in a dictionary +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! subroutine dict_add(dict,key,value) +!! +!! type(dictionary) :: dict +!! character(len=*),intent(in) :: key +!! character(len=*),intent(in) :: VALUE +!! +!!##DESCRIPTION +!! Add or replace a key-value pair in a dictionary. +!! +!!##OPTIONS +!! DICT is the dictionary. +!! key key name +!! VALUE value associated with key +!! +!!##EXAMPLES +!! +!! If string is not found in a sorted array, insert the string +!! +!! program demo_add +!! use M_CLI2, only : dictionary +!! implicit none +!! type(dictionary) :: dict +!! integer :: i +!! +!! call dict%set('A','b') +!! call dict%set('B','^') +!! call dict%set('C',' ') +!! call dict%set('D','c') +!! call dict%set('E','ZZ') +!! call dict%set('F','ZZZZ') +!! call dict%set('G','z') +!! call dict%set('A','new value for A') +!! write(*,'(*(a,"==>","[",a,"]",/))')(trim(dict%key(i)),dict%value(i)(:dict%count(i)),i=1,size(dict%key)) +!! end program demo_add +!! +!! Results: +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine dict_add(self,key,value) + +! ident_50="@(#)M_CLI2::dict_add(3f): place key-value pair into dictionary, adding the key if required" + +class(dictionary),intent(inout) :: self +character(len=*),intent(in) :: key +character(len=*),intent(in) :: value +integer :: place +integer :: place2 + call locate(self%key,key,place) + if(place.lt.1)then + place2=iabs(place) + call insert( self%key, key, place2 ) + call insert( self%value, value, place2 ) + call insert( self%count, len_trim(value), place2 ) + elseif(place.gt.0)then ! replace instead of insert + call insert( self%value, value, place ) + call insert( self%count, len_trim(value), place ) + endif +end subroutine dict_add +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +subroutine many_args(n0,g0, n1,g1, n2,g2, n3,g3, n4,g4, n5,g5, n6,g6, n7,g7, n8,g8, n9,g9, & + & na,ga, nb,gb, nc,gc, nd,gd, ne,ge, nf,gf, ng,gg, nh,gh, ni,gi, nj,gj ) +implicit none + +! ident_51="@(#)M_CLI2::many_args(3fp): allow for multiple calls to get_args(3f)" + +character(len=*),intent(in) :: n0, n1 +character(len=*),intent(in),optional :: n2, n3, n4, n5, n6, n7, n8, n9, na, nb, nc, nd, ne, nf, ng, nh, ni, nj +class(*),intent(out) :: g0, g1 +class(*),intent(out),optional :: g2, g3, g4, g5, g6, g7, g8, g9 +class(*),intent(out),optional :: ga, gb, gc, gd, ge, gf, gg, gh, gi, gj + call get_generic(n0,g0) + call get_generic(n1,g1) + if( present(n2) .and. present(g2) )call get_generic(n2,g2) + if( present(n3) .and. present(g3) )call get_generic(n3,g3) + if( present(n4) .and. present(g4) )call get_generic(n4,g4) + if( present(n5) .and. present(g5) )call get_generic(n5,g5) + if( present(n6) .and. present(g6) )call get_generic(n6,g6) + if( present(n7) .and. present(g7) )call get_generic(n7,g7) + if( present(n8) .and. present(g8) )call get_generic(n8,g8) + if( present(n9) .and. present(g9) )call get_generic(n9,g9) + if( present(na) .and. present(ga) )call get_generic(na,ga) + if( present(nb) .and. present(gb) )call get_generic(nb,gb) + if( present(nc) .and. present(gc) )call get_generic(nc,gc) + if( present(nd) .and. present(gd) )call get_generic(nd,gd) + if( present(ne) .and. present(ge) )call get_generic(ne,ge) + if( present(nf) .and. present(gf) )call get_generic(nf,gf) + if( present(ng) .and. present(gg) )call get_generic(ng,gg) + if( present(nh) .and. present(gh) )call get_generic(nh,gh) + if( present(ni) .and. present(gi) )call get_generic(ni,gi) + if( present(nj) .and. present(gj) )call get_generic(nj,gj) +contains +!=================================================================================================================================== +function c(generic) +class(*),intent(in) :: generic +character(len=:),allocatable :: c + select type(generic) + type is (character(len=*)); c=trim(generic) + class default + c='unknown' + stop 'get_many:: parameter name is not character' + end select +end function c +!=================================================================================================================================== +subroutine get_generic(name,generic) +use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 +character(len=*),intent(in) :: name +class(*),intent(out) :: generic + select type(generic) + type is (integer); call get_args(name,generic) + type is (real); call get_args(name,generic) + type is (real(kind=real64)); call get_args(name,generic) + type is (logical); call get_args(name,generic) + !!type is (character(len=:),allocatable ::); call get_args(name,generic) + type is (character(len=*)); + call get_args_fixed_length(name,generic) + type is (complex); call get_args(name,generic) + class default + stop 'unknown type in *get_generic*' + end select +end subroutine get_generic +!=================================================================================================================================== +end subroutine many_args +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function iget(n); integer :: iget; character(len=*),intent(in) :: n; call get_args(n,iget); end function iget +function rget(n); real :: rget; character(len=*),intent(in) :: n; call get_args(n,rget); end function rget +function dget(n); real(kind=dp) :: dget; character(len=*),intent(in) :: n; call get_args(n,dget); end function dget +function sget(n); character(len=:),allocatable :: sget; character(len=*),intent(in) :: n; call get_args(n,sget); end function sget +function cget(n); complex :: cget; character(len=*),intent(in) :: n; call get_args(n,cget); end function cget +function lget(n); logical :: lget; character(len=*),intent(in) :: n; call get_args(n,lget); end function lget + +function igs(n); integer,allocatable :: igs(:); character(len=*),intent(in) :: n; call get_args(n,igs); end function igs +function rgs(n); real,allocatable :: rgs(:); character(len=*),intent(in) :: n; call get_args(n,rgs); end function rgs +function dgs(n); real(kind=dp),allocatable :: dgs(:); character(len=*),intent(in) :: n; call get_args(n,dgs); end function dgs +function sgs(n); character(len=:),allocatable :: sgs(:); character(len=*),intent(in) :: n; call get_args(n,sgs); end function sgs +function cgs(n); complex,allocatable :: cgs(:); character(len=*),intent(in) :: n; call get_args(n,cgs); end function cgs +function lgs(n); logical,allocatable :: lgs(:); character(len=*),intent(in) :: n; call get_args(n,lgs); end function lgs +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +function ig() +integer,allocatable :: ig(:) +integer :: i, ierr + allocate(ig(size(unnamed))) + do i=1,size(ig) + call a2i(unnamed(i),ig(i),ierr) + enddo +end function ig +!=================================================================================================================================== +function rg() +real,allocatable :: rg(:) + rg=real(dg()) +end function rg +!=================================================================================================================================== +function dg() +real(kind=dp),allocatable :: dg(:) +integer :: i +integer :: ierr + allocate(dg(size(unnamed))) + do i=1,size(dg) + call a2d(unnamed(i),dg(i),ierr) + enddo +end function dg +!=================================================================================================================================== +function lg() +logical,allocatable :: lg(:) +integer :: i +integer :: ichar +character,allocatable :: hold + allocate(lg(size(unnamed))) + do i=1,size(lg) + hold=trim(upper(adjustl(unnamed(i)))) + if(hold(1:1).eq.'.')then ! looking for fortran logical syntax .STRING. + ichar=2 + else + ichar=1 + endif + select case(hold(ichar:ichar)) ! check word to see if true or false + case('T','Y',' '); lg(i)=.true. ! anything starting with "T" or "Y" or a blank is TRUE (true,yes,...) + case('F','N'); lg(i)=.false. ! assume this is false or no + case default + call journal('sc',"*lg* bad logical expression for element",i,'=',hold) + end select + enddo +end function lg +!=================================================================================================================================== +function cg() +complex,allocatable :: cg(:) +integer :: i, ierr +real(kind=dp) :: rc, ic + allocate(cg(size(unnamed))) + do i=1,size(cg),2 + call a2d(unnamed(i),rc,ierr) + call a2d(unnamed(i+1),ic,ierr) + cg(i)=cmplx(rc,ic) + enddo +end function cg +!=================================================================================================================================== +function sg() +character(len=:),allocatable :: sg(:) + sg=unnamed +end function sg +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +subroutine mystop(sig) +integer,intent(in) :: sig + stop sig +end subroutine mystop +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()= +!=================================================================================================================================== +end module M_CLI2 +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== diff --git a/fpm/src/command_line.f90 b/fpm/src/command_line.f90 index cd78904011..c18bcb8ba0 100644 --- a/fpm/src/command_line.f90 +++ b/fpm/src/command_line.f90 @@ -1,5 +1,7 @@ module command_line - use environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS + use environment, only : get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS + use M_CLI2, only : set_args + use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit implicit none private @@ -23,56 +25,143 @@ module command_line end type public :: get_command_line_settings + + integer :: i contains +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine get_command_line_settings(cmd_settings) class(fpm_cmd_settings), allocatable, intent(out) :: cmd_settings + character(len=:),allocatable :: help_text(:), version_text(:) + character(len=100) :: cmdarg ! the subcommand name + version_text=[character(len=132) :: & + & 'VERSION: 1.0.0', & + & 'PROGRAM: fpm(1) ', & + & 'DESCRIPTION: A Fortran package manager and build system', & + & 'HOME PAGE: https://github.com/fortran-lang/fpm', & + & 'LICENSE: MIT', & + & ''] - character(len=100) :: cmdarg - - if (command_argument_count() == 0) then - call print_help() - else if (command_argument_count() == 1) then - call get_command_argument(1, cmdarg) - select case(trim(cmdarg)) - case("new") - allocate(fpm_new_settings :: cmd_settings) - case("build") - allocate(fpm_build_settings :: cmd_settings) - case("run") - allocate(fpm_run_settings :: cmd_settings) - case("test") - allocate(fpm_test_settings :: cmd_settings) - case("install") - allocate(fpm_install_settings :: cmd_settings) - case default - print *, "fpm error: No such command " // trim(cmdarg) - error stop 1 - end select - else - print *, "Too many arguments" - error stop 1 - end if - end subroutine - - subroutine print_help() - print *, "fpm - A Fortran package manager and build system" - select case (get_os_type()) - case (OS_LINUX) - print *, "OS Type: Linux" - case (OS_MACOS) - print *, "OS Type: macOS" - case (OS_WINDOWS) - print *, "OS Type: Windows" - end select - print * - print *, "Usage:" - print *, " fpm [COMMAND]" - print * - print *, "Valid fpm commands are:" - print *, " build Compile the current package" - print *, " install Install a Fortran binary or library (not implemented)" - print *, " new Create a new Fortran package (not implemented)" - print *, " run Run a binary of the local package (not implemented)" - print *, " test Run the tests (not implemented)" - end subroutine + cmdarg='' + do i=1, command_argument_count() + call get_command_argument(i, cmdarg) + if(adjustl(cmdarg(1:1)).ne.'-')exit + enddo + ! now process the subcommand + select case(cmdarg) ! set help text and get command arguments and then call subcommand +!----------------------------------------------------------------------------------------------------------------------------------- + case('run') + help_text=[character(len=132) :: & + ' fpm(1) subcommand "run" ', & + ' ', & + ' Usage: fpm run [NAME(s)] [--release] [--args ARGS|-- ARGS]]|[--help|--version|--usage] ', & + '' ] + call set_args('--args " " --release F --',help_text,version_text) + allocate(fpm_run_settings :: cmd_settings) +!----------------------------------------------------------------------------------------------------------------------------------- + case('build') + help_text=[character(len=132) :: & + ' fpm(1) subcommand "build" ', & + ' ', & + ' Usage: fpm [--release] build |--help|--version|--usage ', & + '' ] + call set_args(' -release F --',help_text,version_text) + allocate(fpm_build_settings :: cmd_settings) +!----------------------------------------------------------------------------------------------------------------------------------- + case('new') + help_text=[character(len=132) :: & + ' fpm(1) subcommand "new" ', & + ' ', & + ' Usage: fpm new NAME [--with-executable] [--with-test]', & + ' Create a new project in a new directory ', & + '' ] + call set_args(' --with-executable F --with-test F ',help_text,version_text) + allocate(fpm_new_settings :: cmd_settings) +!----------------------------------------------------------------------------------------------------------------------------------- + case('install') + help_text=[character(len=132) :: & + ' fpm(1) subcommand "install" ', & + ' ', & + ' ??? NOT IMPLEMENTED ', & + '' ] + call set_args('--args " " -release F ',help_text,version_text) + allocate(fpm_install_settings :: cmd_settings) +!----------------------------------------------------------------------------------------------------------------------------------- + case('test') + help_text=[character(len=132) :: & + ' fpm(1) subcommand "test" ', & + ' ', & + ' Usage: fpm test [NAME(s)] [--release] [--args ARGS|-- ARGS]]|[--help|--version|--usage] ', & + ' ??? NOT IMPLEMENTED ', & + '' ] + call set_args('--args " " -release F --',help_text,version_text) + allocate(fpm_test_settings :: cmd_settings) +!----------------------------------------------------------------------------------------------------------------------------------- + case default + help_text=[character(len=132) :: & + & 'NAME', & + & ' fpm(1) - A Fortran package manager and build system', & + & 'OS TYPE' ] + select case (get_os_type()) + case (OS_LINUX); help_text=[character(len=132) :: help_text, " Linux" ] + case (OS_MACOS); help_text=[character(len=132) :: help_text, " macOS" ] + case (OS_WINDOWS); help_text=[character(len=132) :: help_text, " Windows" ] + end select + help_text=[character(len=132) :: help_text, & + & 'SYNTAX', & + & ' fpm [COMMAND [[--release] [--args ARGS|-- ARGS]]|[--help|--version|--usage] ', & + & ' ', & + & 'DESCRIPTION ', & + & ' A package manager that helps you create Fortran projects that are ', & + & ' optionally dependent on multiple files and other fpm(1) packages. ', & + & 'OPTIONS ', & + & ' ', & + & ' COMMAND Valid fpm commands are: ', & + & ' build Compile the current package ', & + & ' install Install a Fortran binary or library ', & +! & ' uninstall Uninstall a Fortran binary or library ', & + & ' new NAME [--with-executable] [--with-test] Create a new ', & + & ' Fortran package directory with sample files ', & + & ' run [NAME(s)] Run the local package binaries. defaults ', & + & ' to all binaries for that releases. ', & + & ' test [NAME(s)] Run the tests ', & +! & ' search [NAME(s)] search for registered packages to add as ', & +! & ' dependencies. ', & +! & ' list list project files and dependencies ', & + & ' --release Build in release mode (versus debug mode) ', & + & ' fpm(1) Defaults to using common compiler ', & + & ' debug flags and building in ', & + & ' build/gfortran_debug. When this flag is ', & + & ' present build output goes into ', & + & ' build/gfortran_release and common compiler ', & + & ' optimization flags are used. ', & + & ' --args ARGS|-- ARGS Arguments to pass to executables/tests ', & + & ' --help Show this help text and exit ', & + & ' --version Show version information and exit ', & + & 'EXAMPLES ', & + & ' fpm build ', & + & ' fpm new mypackage --with-executable ', & + & ''] + + call set_args('--release F --args "" ',help_text,version_text) + ! Note: will not get here if --version or --usage or --help is present on commandline + write(stderr,'(*(a))')'*fpm* error: unknown or missing subcommand [',trim(cmdarg),']' + help_text=[character(len=132) :: & + & 'Usage: fpm [COMMAND [[--release] [--args ARGS]]|[--help|--version|--usage] ', & + ' Enter "fpm --help" for more information', & + '' ] + do i=1,size(help_text) + write(stderr,'(g0)')trim(help_text(i)) + enddo + stop +!----------------------------------------------------------------------------------------------------------------------------------- + end select + end subroutine get_command_line_settings +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== end module command_line +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== diff --git a/fpm/src/environment.f90 b/fpm/src/environment.f90 index 9190eb61e0..8476ffee77 100644 --- a/fpm/src/environment.f90 +++ b/fpm/src/environment.f90 @@ -1,12 +1,55 @@ module environment - implicit none - private +use,intrinsic :: iso_c_binding, only : c_null_char, c_int +use,intrinsic :: iso_c_binding, only : c_char +use,intrinsic :: iso_c_binding, only : c_float +use,intrinsic :: iso_c_binding, only : c_ptr, c_f_pointer, c_null_ptr +use,intrinsic :: iso_c_binding +use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128 +implicit none +private - integer, parameter, public :: OS_LINUX = 1 - integer, parameter, public :: OS_MACOS = 2 - integer, parameter, public :: OS_WINDOWS = 3 +integer, parameter, public :: OS_LINUX = 1 +integer, parameter, public :: OS_MACOS = 2 +integer, parameter, public :: OS_WINDOWS = 3 + +public :: get_os_type + +public :: system_mkdir +public :: system_chdir +public :: system_perror +public :: system_getcwd +public :: R_GRP, R_OTH, R_USR, RWX_G, RWX_O, RWX_U, W_GRP, W_OTH, W_USR, X_GRP, X_OTH, X_USR +public :: ifmkdir +public :: filewrite +public :: splitpath + +integer,parameter,public :: mode_t=int32 +!integer(kind=mode_t),bind(c,name="S_IRGRP") :: R_GRP +!integer(kind=mode_t),bind(c,name="S_IROTH") :: R_OTH +!integer(kind=mode_t),bind(c,name="S_IRUSR") :: R_USR +!integer(kind=mode_t),bind(c,name="S_IRWXG") :: RWX_G +!integer(kind=mode_t),bind(c,name="S_IRWXO") :: RWX_O +!integer(kind=mode_t),bind(c,name="S_IRWXU") :: RWX_U +!integer(kind=mode_t),bind(c,name="S_IWGRP") :: W_GRP +!integer(kind=mode_t),bind(c,name="S_IWOTH") :: W_OTH +!integer(kind=mode_t),bind(c,name="S_IWUSR") :: W_USR +!integer(kind=mode_t),bind(c,name="S_IXGRP") :: X_GRP +!integer(kind=mode_t),bind(c,name="S_IXOTH") :: X_OTH +!integer(kind=mode_t),bind(c,name="S_IXUSR") :: X_USR + +integer(kind=mode_t),parameter :: R_GRP=32_mode_t +integer(kind=mode_t),parameter :: R_OTH=4_mode_t +integer(kind=mode_t),parameter :: R_USR=256_mode_t +integer(kind=mode_t),parameter :: RWX_G=56_mode_t +integer(kind=mode_t),parameter :: RWX_O=7 _mode_t +integer(kind=mode_t),parameter :: RWX_U=448_mode_t +integer(kind=mode_t),parameter :: W_GRP=16_mode_t +integer(kind=mode_t),parameter :: W_OTH=2 _mode_t +integer(kind=mode_t),parameter :: W_USR=128_mode_t +integer(kind=mode_t),parameter :: X_GRP=8 _mode_t +integer(kind=mode_t),parameter :: X_OTH=1 _mode_t +integer(kind=mode_t),parameter :: X_USR=64 _mode_t - public :: get_os_type contains integer function get_os_type() result(r) ! Determine the OS type @@ -50,5 +93,451 @@ integer function get_os_type() result(r) ! set Linux here. r = OS_LINUX end if - end function + end function get_os_type +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function system_mkdir(dirname,mode) result(ierr) + +! @(#) M_system::system_mkdir(3f): call mkdir(3c) to create empty directory + +character(len=*),intent(in) :: dirname +integer,intent(in) :: mode + integer :: c_mode + integer(kind=c_int) :: err + integer :: ierr + +interface + function c_mkdir(c_path,c_mode) bind(c,name="mkdir") result(c_err) + import c_char, c_int + character(len=1,kind=c_char),intent(in) :: c_path(*) + integer(c_int),intent(in),value :: c_mode + integer(c_int) :: c_err + end function c_mkdir +end interface + + c_mode=mode + err= c_mkdir(str2arr(trim(dirname)),c_mode) + ierr=err ! c_int to default integer kind +end function system_mkdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +pure function str2arr(string) result (array) + +!character(len=*),parameter::ident_32="@(#)M_system::str2arr(3fp): function copies string to null terminated char array" + +character(len=*),intent(in) :: string +character(len=1,kind=c_char) :: array(len(string)+1) + integer :: i + + do i = 1,len_trim(string) + array(i) = string(i:i) + enddo + array(i:i)=c_null_char + +end function str2arr +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine system_chdir(path, err) + +!character(len=*),parameter::ident_15="@(#)M_system::system_chdir(3f): call chdir(3c)" + +character(len=*) :: path +integer, optional, intent(out) :: err + +interface + integer(kind=c_int) function c_chdir(c_path) bind(C,name="chdir") + import c_char, c_int + character(kind=c_char) :: c_path(*) + end function +end interface + integer :: loc_err + + loc_err=c_chdir(str2arr(trim(path))) + if(present(err))then + err=loc_err + endif +end subroutine system_chdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine system_perror(prefix) +use, intrinsic :: iso_fortran_env, only : ERROR_UNIT, INPUT_UNIT, OUTPUT_UNIT ! access computing environment + +! @(#) M_system::system_perror(3f): call perror(3c) to display error message + +character(len=*),intent(in) :: prefix + integer :: ios + +interface + subroutine c_perror(c_prefix) bind (C,name="perror") + import c_char + character(kind=c_char) :: c_prefix(*) + end subroutine c_perror +end interface + + flush(unit=ERROR_UNIT,iostat=ios) + flush(unit=OUTPUT_UNIT,iostat=ios) + flush(unit=INPUT_UNIT,iostat=ios) + call c_perror(str2arr((trim(prefix)))) + !!call c_flush() + +end subroutine system_perror +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine filewrite(filename,filedata) +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +! write filedata to file filename +character(len=*),intent(in) :: filename +character(len=*),intent(in) :: filedata(:) +integer :: lun, i, ios +character(len=256) :: message + message=' ' + ios=0 + if(filename.ne.' ')then + open(file=filename, & + & newunit=lun, & + & form='formatted', & ! FORM = FORMATTED | UNFORMATTED + & access='sequential', & ! ACCESS = SEQUENTIAL | DIRECT | STREAM + & action='write', & ! ACTION = READ|WRITE | READWRITE + & position='rewind', & ! POSITION = ASIS | REWIND | APPEND + & status='new', & ! STATUS = NEW | REPLACE | OLD | SCRATCH | UNKNOWN + & iostat=ios, & + & iomsg=message) + else + lun=stdout + ios=0 + endif + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) + error stop 1 + endif + do i=1,size(filedata) ! write file + write(lun,'(a)',iostat=ios,iomsg=message)trim(filedata(i)) + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',filename,trim(message) + stop 4 + endif + enddo + close(unit=lun,iostat=ios,iomsg=message) ! close file + if(ios.ne.0)then + write(stderr,'(*(a,1x))')'*filewrite* error:',trim(message) + error stop 2 + endif +end subroutine filewrite +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine system_getcwd(output,ierr) + +!$@(#) M_system::system_getcwd(3f):call getcwd(3c) to get pathname of current working directory + +character(len=:),allocatable,intent(out) :: output +integer,intent(out) :: ierr +integer(kind=c_long),parameter :: length=4097_c_long +character(kind=c_char,len=1) :: buffer(length) +type(c_ptr) :: buffer2 +interface + function c_getcwd(buffer,size) bind(c,name="getcwd") result(buffer_result) + import c_char, c_size_t, c_ptr + character(kind=c_char) ,intent(out) :: buffer(*) + integer(c_size_t),value,intent(in) :: size + type(c_ptr) :: buffer_result + end function +end interface +!----------------------------------------------------------------------------------------------------------------------------------- + buffer=' ' + buffer2=c_getcwd(buffer,length) + if(.not.c_associated(buffer2))then + output='' + ierr=-1 + else + output=trim(arr2str(buffer)) + ierr=0 + endif +end subroutine system_getcwd +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +logical function exists(filename) result(r) +character(len=*), intent(in) :: filename +inquire(file=filename, exist=r) +end function +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +elemental impure subroutine ifmkdir(dir) +character(len=*),intent(in) :: dir +if (.not. exists(dir)) then + if( system_mkdir(dir, IANY([R_USR, W_USR, X_USR]) ) .ne. 0)then ! make new directory or stop + call system_perror('error: *fpm::system_mkdir*:'//dir) + stop + endif +endif +end subroutine ifmkdir +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +pure function arr2str(array) result (string) + +!$@(#) M_system::arr2str(3fp): function copies null-terminated char array to string + +character(len=1),intent(in) :: array(:) +character(len=size(array)) :: string +integer :: i + + string=' ' + do i = 1,size(array) + if(array(i).eq.char(0))then + exit + else + string(i:i) = array(i) + endif + enddo + +end function arr2str +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +!> +!!##NAME +!! splitpath(3f) - [M_io] split a Unix pathname into components +!! (LICENSE:PD) +!! +!!##SYNOPSIS +!! +!! splitpath(path,dir,name,basename,ext) +!! +!! integer,parameter :: maxlen=4096 +!! character(len=maxlen),intent(in) :: path +!! character(len=maxlen),intent(out),optional :: dir +!! character(len=maxlen),intent(out),optional :: name +!! character(len=maxlen),intent(out),optional :: basename +!! character(len=maxlen),intent(out),optional :: ext +!! +!!##DESCRIPTION +!! splitpath(3f) splits given pathname assuming a forward slash separates +!! filename components and that the right-most period in the last leaf +!! of the pathname is considered the beginning of an extension. If +!! an extension is found it is left present in NAME but removed from +!! BASENAME. +!! +!! This routine does not check the system for the existence or type of +!! the filename components; it merely parses a string. +!! +!! Assumes leaf separator is a slash ('/') and that filename does not +!! contain trailing spaces. +!! +!!##OPTIONS +!! path Path to be broken into components. It is assumed +!! +!! o Forward slashes (/) separate pathname components. +!! o the name '.' means "current directory" +!! o the name '..' means "up one directory" +!! o a pathname ending in a slash is a directory name +!! o a slash starting the pathname represents the root +!! directory. +!! o trailing spaces are insignificant. +!! +!! Using these rules helps to reduce incorrect parsing, but the +!! routine is only intended for simple parsing of names of the form +!! "[dir/]name[.extension]. +!! +!!##RESULTS +!! dir Path of directories, including the trailing slash. +!! name Name of file leaf or, if no file is specified in path, +!! name of the lowest directory. +!! basename NAME with any extension removed +!! ext File name extension, if any, including the leading period (.). +!! +!! The path parameter can be a complete or partial file specification. The +!! special name "." is assumed to mean the current directory, and the +!! special name ".." is assumed to mean one directory above the current +!! directory. +!! +!!##EXAMPLE +!! +!! program demo_splitpath +!! +!! use m_io, only : splitpath +!! implicit none +!! integer,parameter :: maxlen=4096 +!! character(len=maxlen),parameter :: file(*)=[& +!! & 'dirs/name.ext ', & +!! & 'xx/IO/zz/NN.FF ', & +!! & 'xx/IO/zz/NN ', & +!! & '/xx/IO/zz/NN ', & +!! & '/xx/IO/zz/ ', & +!! & '/xx/IO/zz.A/ ', & +!! & '/xx/IO/zz/. ', & +!! & ' ', & +!! & './ ', & +!! & '/ ', & +!! & '/.. ', & +!! & './.. ', & +!! & 'name. ', & +!! & '.name ', & +!! & '.name. ', & +!! & '. ', & +!! & '.. ', & +!! & '... '] +!! +!! character(len=maxlen) :: dir +!! character(len=maxlen) :: name +!! character(len=maxlen) :: basename +!! character(len=maxlen) :: ext +!! integer :: i +!! integer :: longest +!! longest=maxval(len_trim(file)) ! find longest filename +!! +!! do i=1,size(file) +!! call splitpath(file(i), dir, name, basename, ext) +!! write(*,'(*("| ",a:))') & +!! & file(i)(:longest), & +!! & dir(:longest), & +!! & name(:longest), & +!! & basename(:longest), & +!! & ext(:longest) +!! enddo +!! end program demo_splitpath +!! +!! Output +!! +!! | dirs/name.ext | dirs | name.ext | name | .ext +!! | xx/IO/zz/NN.FF| xx/IO/zz | NN.FF | NN | .FF +!! | xx/IO/zz/NN | xx/IO/zz | NN | NN | +!! | /xx/IO/zz/NN | /xx/IO/zz | NN | NN | +!! | /xx/IO/zz/ | /xx/IO/zz | | | +!! | /xx/IO/zz.A/ | /xx/IO/zz.A | | | +!! | /xx/IO/zz/. | /xx/IO/zz/. | | | +!! | | . | | | +!! | ./ | . | | | +!! | / | / | | | +!! | /.. | / | | | +!! | ./.. | ./.. | | | +!! | name. | | name. | name | . +!! | .name | | .name | .name | +!! | .name. | | .name. | .name | . +!! | . | . | | | +!! | .. | | | | +!! | ... | | ... | .. | . +!! +!!##AUTHOR +!! John S. Urban +!!##LICENSE +!! Public Domain +subroutine splitpath(path,dir,name,basename,ext) +implicit none + +! ident_9="@(#)M_io::splitpath(3f): split Unix pathname into components (dir,name,basename,extension)" + +!=================================================================================================================================== +character(len=*),intent(in) :: path +character(len=:),intent(out),allocatable,optional :: dir +character(len=:),intent(out),allocatable,optional :: name +character(len=:),intent(out),allocatable,optional :: basename +character(len=:),intent(out),allocatable,optional :: ext +integer,parameter :: maxlen=4096 +character(len=maxlen) :: dir_local +character(len=maxlen) :: name_local +character(len=maxlen) :: basename_local +character(len=maxlen) :: ext_local +character(len=len(path)+1) :: path_local +integer :: where +integer :: i +integer :: iend +character(len=1),save :: sep='/' +!=================================================================================================================================== + select case (get_os_type()) + case (OS_LINUX); sep='/' + case (OS_MACOS); sep='/' + case (OS_WINDOWS); sep='\' + end select +!=================================================================================================================================== + path_local=path ! initialize variables + dir_local='' + name_local='' + basename_local='' + ext_local='' + iend=len_trim(path_local) + LOCAL : block +!=================================================================================================================================== + if(iend.eq.0)then ! blank input path + dir_local='.' + exit LOCAL + endif +!=================================================================================================================================== + if(path_local(iend:iend).eq.sep)then ! assume entire name is a directory if it ends in a slash + if(iend.gt.1)then + dir_local=path_local(:iend-1) + else ! if just a slash it means root directory so leave it as slash + dir_local=path_local + endif + exit LOCAL + endif +!=================================================================================================================================== + TRIMSLASHES: do i=iend,1,-1 ! trim off trailing slashes even if duplicates + if(path_local(i:i).eq.sep)then + path_local(i:i)=' ' + iend=i-1 + else + iend=i + exit TRIMSLASHES + endif + enddo TRIMSLASHES + + if(iend.eq.0)then ! path composed entirely of slashes. + dir_local=sep + exit LOCAL + endif +!=================================================================================================================================== + where=INDEX(path_local,sep,BACK=.true.) ! find any right-most slash in remaining non-null name_local after trimming trailing slashes + if(where.le.0)then ! no slash in path so everything left is name_local + name_local=path_local(:iend) ! this is name_local unless '.' or '..' + else ! last slash found + dir_local=path_local(:where-1) ! split into directory + name_local=path_local(where+1:iend) ! this is name_local unless '.' or '..' + endif +!=================================================================================================================================== + select case (name_local(1:3)) ! special cases where name_local is a relative directory name_local '.' or '..' + case('. ') + dir_local=path_local + name_local='' + case('.. ') + if(dir_local.eq.'')then + if(path_local(1:1).eq.sep)then + dir_local=sep + endif + else + dir_local=path_local + endif + name_local='' + case default + end select +!=================================================================================================================================== + if(name_local.eq.'.')then + name_local='' + endif +!=================================================================================================================================== + iend=len_trim(name_local) + where=INDEX(name_local,'.',BACK=.true.) ! find any extension + if(where.gt.0.and.where.ne.1)then ! only consider a non-blank extension name_local + ext_local=name_local(where:) + basename_local=name_local(:where-1) + else + basename_local=name_local + endif +!=================================================================================================================================== + endblock LOCAL + if(present(dir))dir=trim(dir_local) + if(present(name))name=trim(name_local) + if(present(basename))basename=trim(basename_local) + if(present(ext))ext=trim(ext_local) +end subroutine splitpath +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== end module diff --git a/fpm/src/fpm.f90 b/fpm/src/fpm.f90 index 9c8918b002..4333ecbdf9 100644 --- a/fpm/src/fpm.f90 +++ b/fpm/src/fpm.f90 @@ -1,18 +1,24 @@ module fpm -use environment, only: get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS -use fpm_manifest, only : get_package_data, default_executable, default_library, & - & package_t -use fpm_error, only : error_t +use,intrinsic :: iso_fortran_env, only : stdin=>input_unit, stdout=>output_unit, stderr=>error_unit +use environment, only : get_os_type, OS_LINUX, OS_MACOS, OS_WINDOWS +use environment, only : filewrite, system_getcwd, ifmkdir +use M_CLI2, only : get_args, words=>unnamed, remaining +use environment, only : system_mkdir, system_chdir, splitpath +use fpm_manifest, only : get_package_data, default_executable, default_library, package_t +use fpm_error, only : error_t implicit none private public :: cmd_build, cmd_install, cmd_new, cmd_run, cmd_test - type string_t character(len=:), allocatable :: s end type -contains +logical,save :: debug_fpm=.false. +contains +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== integer function number_of_rows(s) result(nrows) ! determine number or rows integer,intent(in)::s @@ -24,21 +30,34 @@ integer function number_of_rows(s) result(nrows) read(s, *, iostat=ios) r if (ios /= 0) exit nrows = nrows + 1 -end do +enddo rewind(s) -end function - - +end function number_of_rows +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +function getsep() +character(len=1) :: getsep + select case (get_os_type()) + case (OS_LINUX); getsep='/' + case (OS_MACOS); getsep='/' + case (OS_WINDOWS); getsep='\' + end select +end function getsep +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine list_files(dir, files) character(len=*), intent(in) :: dir type(string_t), allocatable, intent(out) :: files(:) character(len=100) :: filename -integer :: stat, u, i +character(len=256) :: message +integer :: stat, u, i, ios ! Using `inquire` / exists on directories works with gfortran, but not ifort if (.not. exists(dir)) then allocate(files(0)) return -end if +endif select case (get_os_type()) case (OS_LINUX) call execute_command_line("ls " // dir // " > fpm_ls.out", exitstat=stat) @@ -49,17 +68,22 @@ subroutine list_files(dir, files) end select if (stat /= 0) then print *, "execute_command_line() failed" - error stop -end if + error stop 2 +endif open(newunit=u, file="fpm_ls.out", status="old") allocate(files(number_of_rows(u))) do i = 1, size(files) read(u, *) filename files(i)%s = trim(filename) -end do -close(u) -end subroutine - +enddo +close(u,status='delete',iostat=ios,iomsg=message) +if(ios.ne.0)then + write(*,*)'*list_files* error deleting scratch file:',trim(message) +endif +end subroutine list_files +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine run(cmd) character(len=*), intent(in) :: cmd integer :: stat @@ -67,15 +91,19 @@ subroutine run(cmd) call execute_command_line(cmd, exitstat=stat) if (stat /= 0) then print *, "Command failed" - error stop -end if -end subroutine - + error stop 3 +endif +end subroutine run +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== logical function exists(filename) result(r) character(len=*), intent(in) :: filename inquire(file=filename, exist=r) -end function - +end function exists +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== logical function str_ends_with(s, e) result(r) character(*), intent(in) :: s, e integer :: n1, n2 @@ -85,78 +113,356 @@ logical function str_ends_with(s, e) result(r) r = .false. else r = (s(n1:n2) == e) -end if -end function - +endif +end function str_ends_with +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_build() type(package_t) :: package -type(error_t), allocatable :: error +type(error_t), allocatable :: error type(string_t), allocatable :: files(:) -character(:), allocatable :: basename, linking -integer :: i, n +character(:), allocatable :: basename, linking, main +integer :: i +logical :: release +character(:), allocatable :: release_name, options +character(:), allocatable :: builddir, cmd, inc, appdir +character(len=1),save :: sep='/' + + options='' + call get_args('release',release) + if(release)then + release_name='gfortran_release' + options=' & + & -O3 & + & -Wimplicit-interface & + & -fPIC & + & -fmax-errors=1 & + & -ffast-math & + & -funroll-loops ' + else + release_name='gfortran_debug' + options=' & + & -mtune=generic & + & -Wall & + & -Wextra & + & -g & + & -Wimplicit-interface & + & -fPIC & + & -fmax-errors=1 & + & -fbounds-check & + & -fcheck-array-temporaries& + & -fbacktrace ' + endif + + sep=getsep() + call get_package_data(package, "fpm.toml", error) if (allocated(error)) then print '(a)', error%message error stop 1 -end if +endif + + builddir='build/' // release_name // sep // package%name + inc=' -I ' // builddir // ' -J ' // builddir // ' ' + + !!gfortran bug: call ifmkdir('build', 'build'// sep //release_name, 'build'// sep //release_name// sep //pkg_name]) + call ifmkdir('build') + call ifmkdir('build'// sep //release_name) + call ifmkdir('build'// sep //release_name// sep //package%name) ! Populate library in case we find the default src directory if (.not.allocated(package%library) .and. exists("src")) then call default_library(package%library) -end if +endif ! Populate executable in case we find the default app directory if (.not.allocated(package%executable) .and. exists("app")) then allocate(package%executable(1)) call default_executable(package%executable(1), package%name) -end if +endif if (.not.(allocated(package%library) .or. allocated(package%executable))) then print '(a)', "Neither library nor executable found, there is nothing to do" error stop 1 -end if +endif linking = "" if (allocated(package%library)) then call list_files(package%library%source_dir, files) do i = 1, size(files) if (str_ends_with(files(i)%s, ".f90")) then - n = len(files(i)%s) - basename = files(i)%s - call run("gfortran -c " // package%library%source_dir // "/" // & - & basename // " -o " // basename // ".o") - linking = linking // " " // basename // ".o" - end if - end do -end if + call splitpath(files(i)%s,basename=basename) + call run("gfortran -c " // inc // options // package%library%source_dir // "/" // & + & files(i)%s // " -o " // builddir // sep // basename // ".o") + linking = linking // " " // builddir // sep // basename // ".o" + endif + enddo +endif -do i = 1, size(package%executable) - basename = package%executable(i)%main - call run("gfortran -c " // package%executable(i)%source_dir // "/" // & - & basename // " -o " // basename // ".o") - call run("gfortran " // basename // ".o " // linking // " -o " // & - & package%executable(i)%name) -end do -end subroutine +if(size(files).ne.0)then + call run('ar rv ' // builddir // '/lib' // package%name // '.a ' // builddir // '/*.o') +endif +do i = 1, size(package%executable) + call splitpath(package%executable(i)%main,basename=basename) + appdir= 'build/' // release_name // sep // package%executable(i)%source_dir + !! source_dir could be subdirectories, need recursive ifmkdir + call ifmkdir(appdir) + call run("gfortran -c " // inc // options // & + & package%executable(i)%source_dir // "/" // package%executable(i)%main & + & // " -o " // appdir // sep // basename // ".o") + call run("gfortran " // inc // options // appdir // sep //basename // ".o " // linking // " -o " // & + & appdir// sep //package%executable(i)%name) +enddo +end subroutine cmd_build +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_install() print *, "fpm error: 'fpm install' not implemented." error stop 1 -end subroutine +end subroutine cmd_install +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine cmd_new() ! --with-executable F --with-test F ' +use environment, only : system_perror +use environment, only : R_GRP,R_OTH,R_USR,RWX_G,RWX_O +use environment, only : RWX_U,W_GRP,W_OTH,W_USR,X_GRP,X_OTH,X_USR +!!type(package_t) :: package +!!type(error_t), allocatable :: error +integer :: ierr +character(len=:),allocatable :: dirname ! name of directory specified on "new" subcommand +character(len=:),allocatable :: basename ! baeename of dirname +!character(len=:),allocatable :: writethis(:) +!character(len=4096) :: what_happened +character(len=:),allocatable :: message(:) +character(len=:),allocatable :: littlefile(:) +logical :: with_executable ! command line keyword value set by get_args(3f) +logical :: with_test ! command line keyword value set by get_args(3f) +character(len=1),save :: sep='/' + call get_args('with-executable',with_executable) ! get command line arguments + call get_args('with-test',with_test) + sep=getsep() + ! assume everything unclaimed by keywords on the command line are command arguments for new command + if(size(words).ge.2.and.len(words).gt.0)then + dirname=trim(words(2)) + else ! no directory name to create or update on commandline + write(stderr,'(a)') 'fpm::new missing directory name' + write(stderr,'(a)') ' usage: fpm new DIRECTORY_NAME --with-executable --with-test' + stop + endif + if( system_mkdir(dirname, IANY([R_USR, W_USR, X_USR]) ) .ne. 0)then ! make new directory + call system_perror('fpm::new'//dirname) + !!stop + endif + call system_chdir(dirname,ierr) + if( ierr .ne. 0 )then ! change to new directory + call system_perror('fpm::new'//dirname) + stop + endif + if( system_mkdir('src', IANY([R_USR, W_USR, X_USR]) ) .ne. 0)then ! make new src/ directory + call system_perror('fpm::newsrc') + !!stop + endif + call splitpath(dirname,basename=basename) ! get basename of directory name + if(basename=='')then ! if updating current directory + call system_getcwd(dirname,ierr) + call splitpath(dirname,basename=basename) + endif + littlefile=[character(len=80) :: & + &'module '//basename, & + &' implicit none', & + &' private', & + &'', & + &' public :: say_hello', & + &'contains', & + &' subroutine say_hello', & + &' print *, "Hello, '//basename//'!"', & + &' end subroutine say_hello', & + &'end module '//basename] + !! hit some weird gfortran bug when littlefile data was an argument + call warnwrite('src/'//basename//'.f90',littlefile) + call warnwrite('.gitignore',[character(len=80) :: 'build/*']) -subroutine cmd_new() - print *, "fpm error: 'fpm new' not implemented." - error stop 1 -end subroutine +!! weird gfortran bug?? lines truncated to concatenated string length, not 80 +!! call filewrite('README.md',[character(len=80) :: '# '//basename,'My cool new project!']) -subroutine cmd_run() - print *, "fpm error: 'fpm run' not implemented." - error stop 1 -end subroutine + littlefile=[character(len=80) :: '# '//basename, 'My cool new project!'] + call warnwrite('README.md',littlefile) + message=[character(len=80) :: & ! create fpm.toml + &'name = "'//basename//'" ', & + &'version = "0.1.0" ', & + &'license = "license" ', & + &'author = "Jane Doe" ', & + &'maintainer = "jane.doe@example.com" ', & + &'copyright = "2020 Jane Doe" ', & + &' ', & + &'[library] ', & + &'source-dir="src" ', & + &''] + + if(with_test)then + message=[character(len=80) :: message, & ! create next section of fpm.toml + &'[[test]] ', & + &'name="runTests" ', & + &'source-dir="test" ', & + &'main="main.f90" ', & + &''] + if( system_mkdir('test', IANY([R_USR, W_USR, X_USR]) ) .ne. 0)then ! make new directory or stop + call system_perror('fpm::newtest') + !!stop + endif + littlefile=[character(len=80) :: & + &'program main', & + &'implicit none', & + &'', & + &'print *, "Put some tests in here!"', & + &'end program main'] + call warnwrite('test/main.f90',littlefile) + endif + + if(with_executable)then + message=[character(len=80) :: message, & ! create next section of fpm.toml + &'[[executable]] ', & + &'name="'//basename//'" ', & + &'source-dir="app" ', & + &'main="main.f90" ', & + &''] + if( system_mkdir('app', IANY([R_USR, W_USR, X_USR]) ) .ne. 0)then ! make new directory or stop + call system_perror('fpm::newapp') + !!stop + endif + littlefile=[character(len=80) :: & + &'program main', & + &' use '//basename//', only: say_hello', & + &'', & + &' implicit none', & + &'', & + &' call say_hello', & + &'end program main'] + call warnwrite('app/main.f90',littlefile) + endif + + call warnwrite('fpm.toml',message) + + call run('git init') ! assumes git(1) is installed and in command path + !!call run('git add .') + !!call run('git commit -m "initialized repo"') + contains +!=================================================================================================================================== + subroutine warnwrite(fname,data) + character(len=*),intent(in) :: fname + character(len=*),intent(in) :: data(:) + if(.not.exists(fname))then + call filewrite(fname,data) + else + write(stderr,'(*(g0,1x))')'fpm::new',fname,'already exists. Not overwriting' + endif + end subroutine warnwrite +end subroutine cmd_new +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== +subroutine cmd_run() +character(len=:),allocatable :: release_name, args, cmd, fname +logical :: release +integer :: i, j +type(package_t) :: package +type(error_t), allocatable :: error +character(len=:),allocatable :: newwords(:) +character(len=1),save :: sep='/' +logical,allocatable :: foundit(:) + sep=getsep() + call get_package_data(package, "fpm.toml", error) + if (allocated(error)) then + print '(a)', error%message + error stop 1 + endif + call get_args('args',args) + if(args.ne.'')then + args=args//' '//remaining + else + args=remaining + endif + call get_args('release',release) + release_name=trim(merge('gfortran_release','gfortran_debug ',release)) + if(size(words).eq.1)then + !!words=[character(len=max(len(words),len(package%name))) :: words,package%name] + do i=1,size(package%executable) + fname='build' // sep // release_name // sep // package%executable(i)%source_dir // sep // package%executable(i)%name + words=[character(len=max(len(words),len(fname))) :: words,fname] + enddo + else + !! expand names somehow, duplicates are a problem?? + newwords=['find'] + allocate(foundit(size(words))) + foundit=.false. + FINDIT: do i=1,size(package%executable) + do j=2,size(words) + if(words(j).eq.package%executable(i)%name)then + fname='build' // sep // release_name // sep // package%executable(i)%source_dir // sep // package%executable(i)%name + newwords=[character(len=max(len(newwords),len(fname))) :: newwords,fname] + foundit(j)=.true. + endif + enddo + enddo FINDIT + do i=2,size(words) + if(.not.foundit(i))then + write(stderr,'(*(g0,1x))')'fpm::run:executable',words(i),'not located' + cycle + elseif(debug_fpm)then + write(stderr,'(*(g0,1x))')'fpm::run:executable',words(i),'located at',newwords(i) + endif + enddo + words=newwords + if(allocated(foundit))deallocate(foundit) + deallocate(newwords) + endif + do i=2,size(words) + cmd=words(i) + if(exists(cmd))then + call run(cmd//' '//args) + else + !!call cmd_build() + if(exists(cmd))then + call run(cmd//' '//args) + else + write(stderr,*)'fpm::run',cmd,' not found' + endif + endif + enddo +end subroutine cmd_run +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== subroutine cmd_test() +character(len=:),allocatable :: release_name +logical :: release +character(len=:),allocatable :: args +integer :: i + call get_args('args',args) + if(args.ne.'')then + args=args//' '//remaining + else + args=remaining + endif + call get_args('release',release) + release_name=trim(merge('gfortran_release','gfortran_debug ',release)) + write(*,*)'RELEASE_NAME=',release_name,' ARGS=',args + write(*,*)'SPECIFICALLY NAMED' + do i=2,size(words) + write(*,*)words(i) + enddo print *, "fpm error: 'fpm test' not implemented." error stop 1 -end subroutine - +end subroutine cmd_test +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!=================================================================================================================================== end module fpm +!=================================================================================================================================== +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()! +!===================================================================================================================================