Clicky
Showing changes from revision #0 to #1:
(追記) Added (追記ここまで) | (削除) Removed (削除ここまで) | (削除) Chan (削除ここまで)(追記) ged (追記ここまで)
In Fortran 2003, GET_COMMAND(3f) provides a standard method to read command-line arguments as tokens. The M_KRACKEN(3f) module goes a step further and lets you use Unix-like syntax very easily. You can call your command like this:
./testit -r 333.333 -f /home/urbanjs/testin -l -i 300
with very little code:
Example Usage
!-------------------------------------------------------------------------------
program kracken_test
use m_kracken
character(len=255) :: filename
logical :: lval
! Basically, you define your command using the syntax you will use to use it.
! So, to
! o define command options,
! o default values
! o and apply arguments from command line
! just use
call kracken("cmd", " -i 10 -r 10e3 -l .F. -f input -help .F. -version .F.")
! get the values specified on the command line ...
if(lget("cmd_help"))then
write(*,*)'Write some help text ...'
stop
endif
call retrev('cmd_f',filename,iflen,ier) ! get -f FILENAME
lval = lget("cmd_l") ! get -l present?
rval = rget("cmd_r") ! get -r RVAL
ival = iget("cmd_i") ! get -i INTEGER
! that is it!. Now, do something with the parameters
write(*,*)'filename=',filename(:iflen)
print *, "i=",ival, "r=",rval, "l=",lval
end program kracken_test
!-------------------------------------------------------------------------------M_KRACKEN(3f) provides:
The rest is the source code for the 2008年12月20日 version of the M_KRACKEN(3f) module. (Note that I keep alternate versions and a more extensive write-up of M_KRACKEN(3f) on my personal webpages).
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
! These routines are available for general use. I ask that you send me
! interesting alterations that are available for public use; and that you
! include a note indicating the original author -- John S. Urban
! Last updated Dec 20, 2008
!=======================================================================--------
! :: kracken ! define command and default parameter values
! :: rget ! fetch real value of name VERB_NAME from the language dictionary
! :: iget ! fetch integer value of name VERB_NAME from the language dictionary
! :: lget ! fetch logical value of name VERB_NAME from the language dictionary
! :: sget ! fetch string value of name VERB_NAME from the language dictionary.
! :: retrev ! retrieve token value from Language Dictionary when given NAME
! :: string_to_real ! returns real value from numeric character string NOT USING CALCULATOR
! :: delim ! parse a string and store tokens into an array
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
module M_kracken_dictionary
! @(#) common length of verbs and entries in Language dictionary
! NOTE: many parameters were reduced in size so as to just accomodate
! being used as a command line parser. In particular, some might
! want to change:
! ic=30 ! number of entries in language dictionary
! IPvalue=255 ! ilength of verb value
implicit none
integer, parameter,public :: IPverb=20 ! ilength of verb
integer, parameter,public :: IPvalue=255 ! ilength of verb value
integer, parameter,public :: ic=30 ! number of entries in language dictionary
integer, parameter,public :: k_int = SELECTED_INT_KIND(9) ! integer*4
integer, parameter,public :: k_dbl = SELECTED_REAL_KIND(15,300) ! real*8
!=================================================================--------
! dictionary for Language routines
character (len=IPvalue),dimension(ic),public :: values=" " ! contains the values of string variables
character (len=IPverb),dimension(ic),public :: ix2=" " ! string variable names
integer(kind=k_int),dimension(ic),public :: ivalue=0 ! significant lengths of string variable values
!================================================================---------
end module M_kracken_dictionary
module M_kracken
implicit none
private
! SUBROUTINES:
public :: retrev ! retrieve token value from Language Dictionary when given NAME
public :: string_to_real ! returns real value from numeric character string NOT USING CALCULATOR
public :: kracken ! define command and default parameter values
public :: delim ! parse a string and store tokens into an array
private :: parse_two ! convenient call to parse() -- define defaults, then process user input
private :: parse ! parse user command and store tokens into Language Dictionary
private :: store ! replace dictionary name's value (if allow=add add name if necessary)
private :: bounce ! find location (index) in Language Dictionary where VARNAME can be found
private :: add_string ! Add new string name to Language Library dictionary
private :: send_message
private :: get_command_arguments ! get_command_arguments: return all command arguments as a string
! FUNCTIONS:
public :: rget ! fetch real value of name VERB_NAME from the language dictionary
public :: iget ! fetch integer value of name VERB_NAME from the language dictionary
public :: lget ! fetch logical value of name VERB_NAME from the language dictionary
public :: sget ! fetch string value of name VERB_NAME from the language dictionary.
private :: igets ! return the subscript value of a string when given it's name
private :: uppers ! uppers: return copy of string converted to uppercase
contains
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine retrev(name,val,len,ier)
! Copyright(c) 1989 John S. Urban
!@(#) retrieve token value from Language Dictionary when given NAME
use M_kracken_dictionary ! dictionary for Language routines
character(len=*),intent(in) :: name
character(len=*),intent(out) :: val
integer,intent(out) :: len
integer,intent(out) :: ier
integer :: isub
isub=igets(name) ! get index entry is stored at
if(isub > 0)then ! entry was in dictionary
val=values(isub)
len=ivalue(isub)
ier=0
else ! entry was not in dictionary
ier=-1
val=" "
len=0
endif
end subroutine retrev
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine string_to_real(chars,valu,ierr)
! @(#) returns real value from numeric character string NOT USING CALCULATOR
! Copyright(c) 1989 John S. Urban
!
! returns a real value from a numeric character string.
!
! o works with any g-format input, including integer, real, and
! exponential.
!
! if an error occurs in the read, iostat is returned in ierr and
! value is set to zero. if no error occurs, ierr=0.
!
character(len=*),intent(in) :: chars
real,intent(out) :: valu
integer,intent(out) :: ierr
integer, parameter :: k_dbl = SELECTED_REAL_KIND(15,300) ! real*8
character(len=13) :: frmt
integer :: ios
real(kind=k_dbl) :: valu8
write(unit=frmt,fmt="( ""(bn,g"",i5,"".0)"" )")len(chars)
ierr=0
read(unit=chars,fmt=frmt,iostat=ios)valu8
if (ios /= 0 )then
valu8=0.0_k_dbl
call send_message("*string_to_real* - cannot produce number from this string")
call send_message(chars)
ierr=ios
endif
valu=real(valu8)
end subroutine string_to_real
!=======================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()(
!=======================================================================
function rget(keyword)
! @(#) given keyword, fetch single real value from the language dictionary (zero on error)
real :: rget
character(len=*),intent(in) :: keyword
character(len=255) :: value
integer :: len
integer :: ier
real :: anumber
value=" "
call retrev(keyword, value, len, ier)
call string_to_real(value(:len), anumber, ier)
rget = anumber
end function rget
!=======================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()(
!=======================================================================
function iget(keyword)
! @(#) given keyword, fetch single integer value from the language dictionary (zero on error)
integer :: iget
character(len=*),intent(in) :: keyword
character(len=255) :: value
integer :: len
integer :: ier
real :: anumber
call retrev (keyword, value, len, ier)
call string_to_real (value(:len), anumber, ier)
iget = int(anumber)
end function iget
!=======================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()(
!=======================================================================
function lget (keyword)
! @(#) given keyword, fetch single logical value from the language dictionary (zero on error)
logical :: lget
character(len=*),intent(in) :: keyword
character(len=255) :: value
integer :: len
integer :: ier
call retrev (keyword, value, len, ier)
value=uppers(value,len)
if(value(:len)==" ")then
lget=.true.
elseif(value(:len)=="#N#")then
lget=.false.
elseif(value(:1)=="T")then
lget=.true.
elseif(value(:1)=="F")then
lget=.false.
elseif(value(:2)==".T")then
lget=.true.
elseif(value(:2)==".F")then
lget=.false.
else
call send_message("*lget* bad value for logical for "//keyword(:len_trim(keyword)))
lget=.false.
endif
end function lget
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
! These routines are available for general use. I ask that you send me
! interesting alterations that are available for public use; and that you
! include a note indicating the original author -- John S. Urban
!=======================================================================--------
subroutine kracken(verb,string)
! get the entire command line argument list and pass it and the
! prototype to parse_two()
character (len=*),intent(in) :: string
character (len=*),intent(in) :: verb
character (len=1024) :: command
integer :: ilen
integer :: ier
call get_command_arguments(command,ilen,ier)
call parse_two(verb,string,command,ilen)
end subroutine kracken
!=======================================================================--------
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine parse_two(verb,init,pars,ipars)
!
!@(#) convenient call to parse() -- define defaults, then process user input
!
! verb is the name of the command to be reset/defined and then set
! init is a string used to add a new command or to reset an old one.
! This string is usually hard-set in the program.
! pars is a string defining the command options to be set, usually
! from a user input file
! ipars is the length of the user-input string pars.
character(len=*),intent(in) :: verb
character(len=*),intent(in) :: init
character(len=*),intent(in) :: pars
integer,intent(in) :: ipars
integer :: ipars2
call parse(verb(:len_trim(verb)),init,"add") ! initialize command
if(ipars <= 0)then
ipars2=len(pars)
else
ipars2=ipars
endif
call parse(verb,pars(:ipars2),"no_add") ! process user command options
end subroutine parse_two
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine parse(verb,string,allow)
! Copyright(c) 1989 John S. Urban
!!! need to handle a minus followed by a blank character
!!! set up odd for future expansion
!
!@(#) parse user command and store tokens into Language Dictionary
!
! given a string of form
!
! value -var value -var value
! try to define a bunch of variables of form
! verb_var(i) = value
!
! values may be in double quotes if they contain -alphameric, a #
! signifies rest of line is a comment, adjacent double quotes put
! one double quote into value, processing ends when an unquoted
! semi-colon or end of string is encountered.
! the variable name for the first value is verb_init (often verb_oo)
! call it once to give defaults
! call it again and vars without values are set to null strings
! leading and trailing blanks are removed from values
!
! string is character input string
!
! if ileave is 0, leave double quotes where you find them; else if 1
! remove them. Normally, they should be removed
use M_kracken_dictionary
!=========================================================================
! @(#) for left-over command string for Language routines
! optionally needed if you are going to allow multiple commands on a line
! number of characters left over,
! number of non-blank characters in actual parameter list
!=========================================================================
character(len=*),intent(in) :: verb
character(len=*),intent(in) :: string
character(len=*),intent(in) :: allow
character(len=IPvalue+2) :: dummy
character(len=IPvalue),dimension(2) :: var
character(len=3) :: delmt
character(len=2) :: init
character(len=1) :: currnt
character(len=1) :: prev
character(len=1) :: forwrd
character(len=IPvalue) :: val
character(len=IPverb) :: name
integer,dimension(2) :: ipnt
integer,save :: ileave=1
integer :: ilist
integer :: ier
integer :: islen
integer :: ipln
integer :: ipoint
integer :: itype
integer :: ifwd
integer :: ibegin
integer :: iend
ilist=1
init="oo"
ier=0
islen=len_trim(string) ! find number of characters in input string
! if input string is blank, even default variable will not be changed
if(islen == 0)then
return
endif
dummy=string
ipln=len_trim(verb) ! find number of characters in verb prefix string
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
if(verb(:ipln)=="MODE")then
if(string=="LEAVEQUOTES")then
if(allow=="YES")then
ileave=0
elseif(allow=="NO")then
ileave=1
else
call send_message("*parse* LEAVECODES value bad")
ileave=1
endif
else
call send_message("*parse* UNKNOWN MODE")
endif
return
endif
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
var(2)=init ! initial variable name
var(1)=" " ! initial value of a string
ipoint=0 ! ipoint is the current character pointer for (dummy)
ipnt(2)=2 ! pointer to position in parameter name
ipnt(1)=1 ! pointer to position in parameter value
itype=1 ! itype=1 for value, itype=2 for variable
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
delmt="off"
prev=" "
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
do
ipoint=ipoint+1 ! move current character pointer forward
currnt=dummy(ipoint:ipoint) ! store current character into currnt
ifwd=min(ipoint+1,islen)
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 parameter name
if(ipnt(1)-1 >= 1)then
ibegin=1
iend=len_trim(var(1)(:ipnt(1)-1))
do
if(iend == 0)then !len_trim returned 0, parameter value is blank
iend=ibegin
exit
else if(var(1)(ibegin:ibegin) == " ")then
ibegin=ibegin+1
else
exit
endif
enddo
name=verb(:ipln)//"_"//var(2)(:ipnt(2))
val=var(1)(ibegin:iend)
call store(name,val,allow,ier) ! store name and it's value
else
name=verb(:ipln)//"_"//var(2)(:ipnt(2))
val=" " ! store name and null value
call store(name,val,allow,ier)
endif
ilist=ilist+ipln+1+ipnt(2)
ilist=ilist+1
itype=2 ! change to filling a variable name
var(1)=" " ! clear value for this variable
var(2)=" " ! clear variable name
ipnt(1)=1 ! restart variable value
ipnt(2)=1 ! restart variable name
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
elseif(currnt == "#".and.delmt == "off")then ! rest of line is comment
islen=ipoint
dummy=" "
prev=" "
cycle
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
! rest of line is another command(s)
islen=ipoint
dummy=" "
prev=" "
cycle
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
else ! currnt is not one of the special characters
! the space after a keyword before the value
if(currnt == " ".and.itype == 2)then
! switch from building a keyword string to building a value string
itype=1
! beginning of a delimited parameter value
elseif(currnt == """".and.itype == 1)then
! second of a double quote, put quote in
if(prev == """")then
var(itype)(ipnt(itype):ipnt(itype))=currnt
ipnt(itype)=ipnt(itype)+1
delmt="on"
elseif(delmt == "on")then ! first quote of a delimited string
delmt="off"
else
delmt="on"
endif
if(ileave == 0.and.prev /= """")then ! leave quotes where found them
var(itype)(ipnt(itype):ipnt(itype))=currnt
ipnt(itype)=ipnt(itype)+1
endif
else ! add character to current parameter name or parameter value
var(itype)(ipnt(itype):ipnt(itype))=currnt
ipnt(itype)=ipnt(itype)+1
if(currnt /= " ")then
endif
endif
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
endif
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
prev=currnt
if(ipoint <= islen)then
cycle
endif
exit
enddo
end subroutine parse
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine store(name1,value1,allow1,ier)
! Copyright(c) 1989 John S. Urban
!
!@(#) replace dictionary name's value (if allow=add add name if necessary)
use M_kracken_dictionary
character(len=*),intent(in) :: name1
character(len=*),intent(in) :: value1
character(len=*),intent(in) :: allow1
integer,intent(out) :: ier
character(len=IPverb) :: name
integer :: indx
character(len=10) :: allow
character(len=IPvalue) :: value
character(len=IPvalue) :: mssge ! the message/error/string value
integer :: nlen
integer :: new
integer :: ii
integer :: i10
name=name1
value=value1
allow=allow1
nlen=len(name1)
! determine storage placement of the variable and whether it is new
call bounce(name,indx,ix2,ier,mssge)
if(ier == -1)then
call send_message("error occurred in *store*")
call send_message(mssge)
return
endif
if(indx > 0)then
! found the variable name
new=1
! check if the name needs added or is already defined
else if(indx <= 0.and.allow == "add")then
! adding the new variable name in the variable name array
call add_string(name,nlen,indx,ier)
if(ier == -1)then
call send_message("*store* could not add "//name(:nlen))
call send_message(mssge)
return
endif
new=0
else
! did not find variable name but not allowed to add it
!call send_message("could not find "//name)
call send_message("E-R-R-O-R: UNKNOWN OPTION "//name)
ii=index(name,"_")
if(ii > 0)then
call send_message(name(:ii-1)//" parameters are")
do i10=1,ic
if(name(:ii) == ix2(i10)(:ii))then
call send_message(" -"//ix2(i10)(ii+1:len_trim(ix2(i10)))//" "//values(i10)(:ivalue(i10)))
endif
enddo
endif
return
endif
! ignore special value that means leave alone, used by 'set up' calls to
! leave a value alone
! note that this will prevent the keyword from being defined.
if(value(1:4) == "@LV@")then
! a new leave-alone flag (for use by a 'defining' call)
if(new == 0) then
value=value(5:) ! trim off the leading @LV@
values(iabs(indx))=value ! store a defined variable's value
ivalue(iabs(indx))=len_trim(value) ! store ilength of string
endif
else
values(iabs(indx))=value ! store a defined variable's value
ivalue(iabs(indx))=len_trim(value) ! store ilength of string
endif
end subroutine store
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine bounce(varnam,index,ixn,ier,mssge)
! Copyright(C) 1989 John S. Urban
!
!@(#) find location (index) in Language Dictionary where VARNAME can be found
! (Assuming an alphabetized array of character strings)
!
! If it is not found report where it
! should be placed as a NEGATIVE index number.
!
! It is assumed all variable names are lexically greater
! than a blank string.
use M_kracken_dictionary
character(len=*),intent(in) :: varnam
integer,intent(out) :: index
!character(len=IPverb),dimension(ic),intent(in) :: ixn
character(len=*),dimension(:),intent(in) :: ixn
integer,intent(out) :: ier
character(len=*),intent(out) :: mssge
integer :: maxtry
integer :: imin
integer :: imax
integer :: i10
maxtry=int(log(float(ic))/log(2.0)+1.0)
index=(ic+1)/2
imin=1
imax=ic
do i10=1,maxtry
if(varnam == ixn(index))then
return
else if(varnam > ixn(index))then
imax=index-1
else
imin=index+1
endif
if(imin > imax)then
index=-imin
if(iabs(index) > ic)then
mssge="error 03 in bounce"
ier=-1
return
endif
return
endif
index=(imax+imin)/2
if(index > ic.or.index <= 0)then
mssge="error 01 in bounce"
ier=-1
return
endif
enddo
mssge="error 02 in bounce"
end subroutine bounce
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine add_string(newnam,nchars,index,ier)
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
!@(#) Add new string name to Language Library dictionary
use M_kracken_dictionary
! maximum number of string variables to be stored
character(len=*),intent(in) :: newnam
integer,intent(in) :: nchars
integer,intent(in) :: index
integer,intent(out) :: ier
integer :: istart
integer :: i10
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
! if last position in the name array has already been used, then
! report that no room is left and set error flag and error message.
if(ix2(ic) /= " ")then
call send_message("*add_string* no room left to add more string variable names")
ier=-1
return
endif
!=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
istart=iabs(index)
! watch out when ic approaches istart that logic is correct.
do i10=ic-1,istart,-1
! pull down the array to make room for new value
values(i10+1)=values(i10)
ivalue(i10+1)=ivalue(i10)
ix2(i10+1)=ix2(i10)
enddo
values(istart)=" "
ivalue(istart)= 0
ix2(istart)=newnam(1:nchars)
return
end subroutine add_string
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
function igets(chars0)
! Copyright(c) 1989 John S. Urban
!@(#) return the subscript value of a string when given it's name
! WARNING: only request value of names known to exist
use M_kracken_dictionary ! dictionary for Language routines
character(len=*),intent(in) :: chars0
character(len=IPvalue) :: msg
character(len=IPverb) :: chars
character(len=IPvalue) :: mssge
integer :: ierr
integer :: index
integer :: igets
chars=chars0
ierr=0
index=0
call bounce(chars,index,ix2,ierr,mssge) ! look up position
if((ierr == -1).or.(index <= 0))then
msg="*igets* variable "//chars//" undefined"
call send_message(msg)
!!!!!! very unfriendly subscript value
igets=-1
else
igets=index
endif
end function igets
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine delim(line0,array,n,iicount,ibegin,iterm,ilen,dlim)
! @(#) parse a string and store tokens into an array
!
! given a line of structure " par1 par2 par3 ... parn "
! store each par(n) into a separate variable in array.
!
! IF ARRAY(1) = '#NULL#' do not store into string array (KLUDGE))
!
! also icount number of elements of array initialized, and
! return beginning and ending positions for each element.
! also return position of last non-blank character (even if more
! than n elements were found).
!
! no quoting of delimiter is allowed
! no checking for more than n parameters, if any more they are ignored
!
character(len=*),intent(in) :: line0
integer,intent(in) :: n
!character(len=*),dimension(n),intent(out) :: array
character(len=*),dimension(:),intent(out) :: array
integer,intent(out) :: iicount
!integer,dimension(n),intent(out) :: ibegin
integer,dimension(:),intent(out) :: ibegin
!integer,dimension(n),intent(out) :: iterm
integer,dimension(:),intent(out) :: iterm
integer,intent(out) :: ilen
character(len=*),intent(in) :: dlim
character(len=1044) :: line
logical :: lstore
integer :: idlim
integer :: icol
integer :: iarray
integer :: istart
integer :: iend
integer :: i10
integer :: ifound
iicount=0
ilen=len_trim(line0)
if(ilen > 1044)then
call send_message("*delim* input line too long")
endif
line=line0
idlim=len(dlim)
if(idlim > 5)then
idlim=len_trim(dlim) ! dlim a lot of blanks on some machines if dlim is a big string
if(idlim == 0)then
idlim=1 ! blank string
endif
endif
! command was totally blank
if(ilen == 0)then
return
endif
!
! there is at least one non-blank character in the command
! ilen is the column position of the last non-blank character
! find next non-delimiter
icol=1
if(array(1) == "#NULL#")then ! special flag to not store into character array
lstore=.false.
else
lstore=.true.
endif
do iarray=1,n,1 ! store into each array element until done or too many words
if(index(dlim(1:idlim),line(icol:icol)) == 0)then ! if current character is not a delimiter
istart=icol ! start new token on the non-delimiter character
ibegin(iarray)=icol
iend=ilen-istart+1+1 ! assume no delimiters so put past end of line
do i10=1,idlim
ifound=index(line(istart:ilen),dlim(i10:i10))
if(ifound > 0)then
iend=min(iend,ifound)
endif
enddo
if(iend <= 0)then ! no remaining delimiters
iterm(iarray)=ilen
if(lstore)then
array(iarray)=line(istart:ilen)
endif
iicount=iarray
return
else
iend=iend+istart-2
iterm(iarray)=iend
if(lstore)then
array(iarray)=line(istart:iend)
endif
endif
icol=iend+2
else
icol=icol+1
cycle
endif
! last character in line was a delimiter, so no text left
! (should not happen where blank=delimiter)
if(icol > ilen)then
iicount=iarray
return
endif
enddo
! more than n elements
iicount=n
end subroutine delim
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
subroutine send_message(msg) ! general message routine
! use ISO_FORTRAN_ENV, only: ERROR_UNIT
! SIMPLIFIED FOR M_KRACKEN: JUST ECHOES MESSAGES
character(len=*),intent(in) :: msg
! write(ERROR_UNIT,'(a)')'#kracken>:'//trim(msg)
print "("" #kracken>:"",a)", trim(msg) ! echo mode
end subroutine send_message
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
! currently, get_command may or may not contain the command name as well as the
! arguments, and some systems allow blank spaces or other characters that can
! confuse. This routine returns all the arguments as a string.
subroutine get_command_arguments(string,istring_len,istatus)
! @(#)get_command_arguments: return all command arguments as a string
character(len=*),intent(out) :: string ! string of all arguments
integer,intent(out) :: istring_len ! last character position set
integer,intent(out) :: istatus ! status (non-zero means error)
integer :: ilength ! length of individual arguments
integer :: i ! loop count
integer :: icount ! count of number of arguments available
character(len=255) :: value ! store individual arguments one at a time
string="" ! initialize returned output string
istring_len=0 ! initialize returned output string length
istatus=0 ! initialize returned error code
icount=command_argument_count() ! intrinsic gets number of arguments
if(icount>0)then ! if there are arguments load them into string
! start with first argument
call get_command_argument(1,string,istring_len,istatus)
if(istatus == 0)then
do i=2,icount ! append any additional arguments to first
call get_command_argument(i,value,ilength,istatus)
if(istatus /= 0)then
exit ! stop on error
endif
string=string(:istring_len)//" "//value(:ilength)
istring_len=istring_len+ilength+1
enddo
endif
! keep track of length and so do not need to use len_trim
istring_len=len_trim(string)
endif
end subroutine get_command_arguments
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
function uppers(linei,ilen) result (string)
! @(#)uppers: return copy of string converted to uppercase
! Copyright 1996 (c), John S. Urban
! put back in if length of input longer than length of output
character(len=*),intent(in) :: linei
integer,intent(in) :: ilen
character(len=ilen) :: string
character(len=1) :: let
integer :: ilet
integer :: iout
integer :: i10
iout=1
string=" "
do i10=1,ilen,1
let=linei(i10:i10)
ilet=ichar(let)
! lowercase a-z in ASCII is 97 to 122
! uppercase a-z in ASCII is 65 to 90
if( (ilet >= 97) .and. (ilet <= 122))then
! convert lowercase a-z to uppercase a-z
string(iout:iout)=char(ilet-32)
else
! character is not an uppercase a-z, just put it in output
string(iout:iout)=let
endif
iout=iout+1
enddo
end function uppers
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
function sget(name,ilen) result (string)
!@(#) Fetch string value of specified NAME from the language dictionary.
! Copyright(C) 1989,2008 John S. Urban
!
! This routine trusts that the desired name exists. A blank
! is returned if the name is not in the dictionary
use M_kracken_dictionary ! dictionary for Language routines
character(len=*),intent(in) :: name ! name to look up in dictionary
integer,intent(in) :: ilen ! length of returned output string
character(len=ilen) :: string
integer :: isub
isub=igets(name) ! given name return index name is stored at
if(isub > 0)then ! if index is valid return string
string=values(isub)
else ! if index is not valid return blank string
string(:)=" "
endif
end function sget
!=======================================================================--------
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
!=======================================================================--------
end module M_kracken