C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- C These routines are available for general use. I ask that you send me C interesting alterations that are available for public use; and that you C include a note indicating the original author -- John S. Urban C=======================================================================-------- subroutine kracken(verb,string) C get the entire command line argument list and pass it and the C prototype to P2() character *(*) string character*(*) verb character*1024 command call get_command_arguments(command,ilen,ier) call p2(verb,string,command,ilen) return end C=======================================================================-------- C NOTE: many parameters were reduced in size so as to just accomodate C being used as a command line parser. In particular, some might C want to change: C parameter(ic=30) ! number of entries in language dictionary C parameter(IPvalue=255) ! length of verb value C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- block data juinit2 implicit real (a-h,o-z) C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- data values/ic*' '/ data ix2/ic*' '/ data ivalue/ic*0/ end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine p2(verb,init,pars,ipars) C C@(#) convenient call to parse() -- define defaults, then process user input C C verb is the name of the command to be reset/defined and then set C init is a string used to add a new command or to reset an old one. C This string is usually hard-set in the program. C pars is a string defining the command options to be set, usually C from a user input file C ipars is the length of the user-input string pars. character verb*(*),init*(*),pars*(*) integer ipars integer ipars2 intrinsic len external parse call parse(verb(:julen(verb)),init,'add') ! initialize command if(ipars.le.0)then ipars2=len(pars) else ipars2=ipars endif call parse(verb,pars(:ipars2),'no_add') ! process user command options return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine parse(verb,string,allow) C Copyright(c) 1989 John S. Urban all rights reserved C!! need to handle a minus followed by a blank character C!! set up odd for future expansion C C@(#) parse user command and store tokens into Language Dictionary C C given a string of form C C value -var value -var value C try to define a bunch of variables of form C verb_var(i) = value C C values may be in double quotes if they contain -alphameric, a # C signifies rest of line is a comment, adjacent double quotes put C one double quote into value, processing ends when an unquoted C semi-colon or end of string is encountered. the remainder of the C command line may be found in the common variable CLEFTQ. C the variable name for the first value is verb_init (often verb_oo) C call it once to give defaults C call it again and vars without values are set to null strings C leading and trailing blanks are removed from values C C in common (for use with multiple commands per line): C leftq number of characters in cleftq C clistq list of dictionary terms stored in form name|name|name| C cleftq string containing any part of command after semi-colon C islenq number of characters in the command up to last " if present C (minus comments, extra commands, trailing blanks) C C string is 255 character input string C C if ileave is 0, leave double quotes where you find them; else if 1 C remove them. Normally, they should be removed implicit real (a-h,o-z) C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary C @(#) common block include file for left-over command string for Language routines C========================================================================= C optional common blocks needed if you are going to allow C multiple commands on a line character*(IPvalue) cleftq,clistq common /zdumq/ cleftq,clistq ! number of characters left over, ! number of non-blank characters in actual parameter list common /zleftq/ leftq,islenq save /zleftq/,/zdumq/ C========================================================================= character*(*) string, verb character dummy*(IPvalue+2),var(2)*(IPvalue),delmt*3,init*2 character currnt*1, allow*(*),prev*1, forwrd*1 integer ipnt(2) character*(IPvalue) val character*(IPverb) name save ileave data ileave/1/ clistq=' ' ilist=1 leftq=0 islenq=0 init='oo' ier=0 islen=julen(string) ! find number of characters in input string ! if input string is blank, even default variable will not be changed if(islen.eq.0)return dummy=string ipln=julen(verb) ! find number of characters in verb prefix string C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= if(verb(:ipln).eq.'MODE')then if(string.eq.'LEAVEQUOTES')then if(allow.eq.'YES')then ileave=0 elseif(allow.eq.'NO')then ileave=1 else call jun(4,'*parse* LEAVECODES value bad') ileave=1 endif else call jun(4,'*parse* UNKNOWN MODE') endif return endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= 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 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= delmt='off' prev=' ' 1 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) C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= if((currnt.eq.'-'.and.prev.eq.' '.and.delmt.eq.'off'.and. ! beginning of a parameter name &index('0123456789.',forwrd).eq.0).or.ipoint.gt.islen)then if(ipnt(1)-1.ge.1)then ibegin=1 iend=julen(var(1)(:ipnt(1)-1)) 4 if(iend.eq.0)then !julen returned 0, parameter value is blank iend=ibegin else if(var(1)(ibegin:ibegin).eq.' ')then ibegin=ibegin+1 goto 4 endif 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 ! store list of stored names into clistq variable clistq(ilist:)=name ilist=ilist+ipln+1+ipnt(2) clistq(ilist:ilist)='|' 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 if(currnt.ne.' ')islenq=ipoint C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= elseif(currnt.eq.'#'.and.delmt.eq.'off')then ! rest of line is comment islen=ipoint leftq=0 dummy=' ' cleftq=' ' prev=' ' goto 1 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= ! rest of line is another command(s) elseif(currnt.eq.';'.and.delmt.eq.'off')then leftq=islen-ipoint if(leftq.gt.0)then cleftq=dummy(ipoint+1:) else cleftq=' ' endif islen=ipoint dummy=' ' prev=' ' goto 1 C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= else ! currnt is not one of the special characters ! the space after a keyword before the value if(currnt.eq.' '.and.itype.eq.2)then ! switch from building a keyword string to building a value string itype=1 ! beginning of a delimited parameter value elseif(currnt.eq.'"'.and.itype.eq.1)then ! second of a double quote, put quote in if(prev.eq.'"')then var(itype)(ipnt(itype):ipnt(itype))=currnt ipnt(itype)=ipnt(itype)+1 islenq=ipoint delmt='on' elseif(delmt.eq.'on')then ! first quote of a delimited string delmt='off' else delmt='on' endif if(ileave.eq.0.and.prev.ne.'"')then ! leave quotes where found them var(itype)(ipnt(itype):ipnt(itype))=currnt ipnt(itype)=ipnt(itype)+1 islenq=ipoint 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.ne.' ')then islenq=ipoint endif endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= prev=currnt if(ipoint.le.islen)goto 1 return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine store(name1,value1,allow1,ier) C Copyright(c) 1989 John S. Urban all rights reserved C C@(#) replace dictionary name's value (if allow=add add name if necessary) implicit real (a-h,o-z) C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- character name*(IPverb),value*(IPvalue) character mssge*(IPvalue) character allow*10 character name1*(*) ,value1*(*) ,allow1*(*) common/zumssg/mssge ! the message/error/string value common save /zumssg/ name=name1 value=value1 allow=allow1 nlen=len(name1) ! determine storage placement of the variable and whether it is new call jubous2(name,indx,ix2,ier) if(ier.eq.-1)then call jun(4,'error occurred in *store*') call jun(4,mssge) return endif if(indx.gt.0)then C found the variable name new=1 ! check if the name needs added or is already defined else if(indx.le.0.and.allow.eq.'add')then ! adding the new variable name in the variable name array call juadds2(name,nlen,indx,ier) if(ier.eq.-1)then call jun(4,'*store* could not add '//name(:nlen)) call jun(4,mssge) return endif new=0 else C did not find variable name but not allowed to add it !call jun(4,'could not find '//name) call jun(4,'E-R-R-O-R: UNKNOWN OPTION '//name) 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).eq.'@LV@')then ! a new leave-alone flag (for use by a 'defining' call) if(new.eq.0) then value=value(5:) ! trim off the leading @LV@ values(iabs(indx))=value ! store a defined variable's value ivalue(iabs(indx))=julen(value) ! store length of string endif else values(iabs(indx))=value ! store a defined variable's value ivalue(iabs(indx))=julen(value) ! store length of string endif return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine jubous2(varnam,index,ixn,ier) C Copyright(C) 1989 John S. Urban All rights reserved C C@(#) find location (index) in Language Dictionary where VARNAME can be found C (Assuming an alphabetized array of character strings) C C If it is not found report where it C should be placed as a NEGATIVE index number. C C It is assumed all variable names are lexically greater C than a blank string. implicit real (a-h,o-z) C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary character mssge*(IPvalue) ,varnam*(*) integer maxtry character*(IPverb) ixn(ic) common/zumssg/mssge save /zumssg/ maxtry=int(log(float(ic))/log(2.0)+1.0) index=(ic+1)/2 imin=1 imax=ic do 10 i10=1,maxtry if(varnam.eq.ixn(index))then return else if(varnam.gt.ixn(index))then imax=index-1 else imin=index+1 endif if(imin.gt.imax)then index=-imin if(iabs(index).gt.ic)then mssge='error 03 in jubous2' ier=-1 return endif return endif index=(imax+imin)/2 if(index.gt.ic.or.index.le.0)then mssge='error 01 in jubous2' ier=-1 return endif 10 continue mssge='error 02 in jubous2' return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine juadds2(newnam,nchars,index,ier) C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C@(#) Add new string name to Language Library dictionary implicit real (a-h,o-z) C maximum number of string variables to be stored C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- character newnam*(*), mssge*(IPvalue) C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= C if last position in the name array has already been used, then C report that no room is left and set error flag and error message. if(ix2(ic).ne.' ')then mssge='*juadds2* no room left to add more string variable names' ier=-1 return endif C=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= istart=iabs(index) C watch out when ic approaches istart that logic is correct. do 70 i70=ic-1,istart,-1 C pull down the array to make room for new value values(i70+1)=values(i70) ivalue(i70+1)=ivalue(i70) 70 ix2(i70+1)=ix2(i70) values(istart)=' ' ivalue(istart)= 0 ix2(istart)=newnam(1:nchars) return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine retrev(name,val,len,ier) c Copyright(c) 1989 John S. Urban all rights reserved C@(#) retrieve token value from Language Dictionary when given NAME C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- character name*(*) ,val*(*) integer igets external igets isub=igets(name) ! get index entry is stored at if(isub.gt.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 return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- function igets(chars0) C Copyright(c) 1989 John S. Urban all rights reserved C@(#) return the subscript value of a string when given it's name C WARNING: only request value of names known to exist implicit real (a-h,o-z) integer igets C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- character*(*) chars0,msg*(IPvalue),chars*(IPverb) chars=chars0 ierr=0 index=0 call jubous2(chars,index,ix2,ierr) ! look up position if((ierr.eq.-1).or.(index.le.0))then msg='*igets* variable '//chars//' undefined' call jun(6,msg) C!!!!! very unfriendly subscript value igets=-1 else igets=index endif return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- character*(*) function fetch(name) C Copyright(C) 1989 John S. Urban all rights reserved C C@(#) Fetch string value of specified NAME from the language dictionary. C C This routine trusts that the desired name exists. A blank C is returned if the name is not in the dictionary character name*(*) ! name to look up in dictionary C @(#) include file with length of verbs and entries in Language dictionary parameter(IPverb=20) ! length of verb parameter(IPvalue=255) ! length of verb value parameter(ic=30) ! number of entries in language dictionary !=================================================================-------- ! @(#) common block include file for dictionary for Language routines character values(ic)*(IPvalue) character ix2(ic)*(IPverb) common /jindx2/ix2 ! string variable names common /jstrng/values ! contains the values of string variables common /jstrln/ivalue(ic) ! significant lengths of string variable values save /jindx2/,/jstrng/,/jstrln/ !================================================================--------- integer igets external igets isub=igets(name) ! given name return index name is stored at if(isub.gt.0)then ! if index is valid return string fetch=values(isub) else ! if index is not valid return blank string fetch(:)=' ' endif return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine string_to_real(chars,valu,ierr) C @(#) returns real value from numeric character string NOT USING CALCULATOR C Copyright(c) 1989 John S. Urban all rights reserved C C returns a real value from a numeric character string. C C o works with any g-format input, including integer, real, and C exponential. C C if an error occurs in the read, iostat is returned in ierr and C value is set to zero. if no error occurs, ierr=0. C character*(*) chars, frmt*13 write(frmt,101)len(chars) 101 format( '(bn,g',i5,'.0)' ) ierr=0 read(chars,fmt=frmt,iostat=ierr,err=999)valu return 999 valu=0.0 call jun(4,'*juar* - cannot produce number from this string') call jun(4,chars) return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine delim(line0,array,n,icount,ibegin,iterm,ilen,dlim) C @(#) parse a string and store tokens into an array C C given a line of structure " par1 par2 par3 ... parn " C store each par(n) into a separate variable in array. C C IF ARRAY(1).eq.'#NULL#' do not store into string array (KLUDGE)) C C also count number of elements of array initialized, and C return beginning and ending positions for each element. C also return position of last non-blank character (even if more C than n elements were found). C C no quoting of delimiter is allowed C no checking for more than n parameters, if any more they are ignored C character*(*) line0, dlim*(*) character*1044 line character array(n)*(*) integer icount, ibegin(n),iterm(n),ilen logical lstore cx parameter (dlim=' ') icount=0 ilen=julen(line0) if(ilen.gt.1044)then call jun(4,'*delim* input line too long') endif line=line0 idlim=len(dlim) if(idlim.gt.5)then idlim=julen(dlim) ! dlim a lot of blanks on some machines if dlim is a big string if(idlim.eq.0)idlim=1 ! blank string endif C command was totally blank if(ilen.eq.0)return C C there is at least one non-blank character in the command C ilen is the column position of the last non-blank character C find next non-delimiter icol=1 if(array(1).eq.'#NULL#')then ! special flag to not store into character array lstore=.false. else lstore=.true. endif do 100 iarray=1,n,1 ! store into each array element until done or too many words 200 if(index(dlim(1:idlim),line(icol:icol)).eq.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 10 i10=1,idlim ifound=index(line(istart:ilen),dlim(i10:i10)) if(ifound.gt.0)then iend=min(iend,ifound) endif 10 continue if(iend.le.0)then ! no remaining delimiters iterm(iarray)=ilen if(lstore)array(iarray)=line(istart:ilen) icount=iarray return else iend=iend+istart-2 iterm(iarray)=iend if(lstore)array(iarray)=line(istart:iend) endif icol=iend+2 else icol=icol+1 goto 200 endif C last character in line was a delimiter, so no text left C (should not happen where blank=delimiter) if(icol.gt.ilen)then icount=iarray return endif 100 continue C more than n elements icount=n return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine jun(icode,msg) ! general message routine c Copyright(c) 1989 John S. Urban all rights reserved C C provides page mode. pause every nth lines (and clear screen on storage tubes) C writes error messages and general information text to standard C output and the trace file C icode=1 write to trail file and standard output C icode=2 write only to standard output C icode=3 write only to trail file C icode=4 write to trail file as a comment and standard output C icode=5 write to trail file as a comment C icode=6 do not write at all (print manually for some debug messages) C icode=-6 change trail file (back) to standard out C icode=-90 change trail file to a user-open unit 90 (typical first usage) C C the trace file messages are preceded by a pound (#) so C they will be interpreted as comments if the trace file is C subsequently used as input data for the program C C C SIMPLIFIED FOR EXAMPLE: JUST ECHOES MESSAGES C character*(*) msg external julen integer julen ilen=julen(msg) write(*,'('' >:'',a)') msg(:ilen) ! echo mode return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- integer function julen(string) C @(#) return position of last non-blank character in "string". C Copyright(C) 1984 John S. Urban all rights reserved C if the string is blank, a length of 0 is returned. C - consider: might like to ignore trailing carriage returns and C tabs and other white space too C - mod 1: 1994 C added null (char(0)) because HP and some Suns not padding C strings with blank, but with null characters; 1994 JSU C C NB: F90 has an intrinsic called LEN_TRIM that makes julen obsolete. character string*(*) character null*1 intrinsic len null=char(0) ilen=len(string) if(ilen.ge.1)then ! check for null strings do 10 i10=ilen,1,-1 if(string(i10:i10).ne.' '.and.string(i10:i10).ne.null)then julen=i10 return endif 10 continue endif julen=0 return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- character*(*) function uppers(linei) C @(#)uppers: return copy of string converted to uppercase C Copyright 1996 (c), John S. Urban character*(*) linei, let*1 intrinsic ichar, char, len external julen integer julen iout=1 inlen=len(linei) ioutlen=len(uppers) ! is this ANSI FORTRAN77? if(ioutlen.lt.inlen)then inlen=max(1,julen(linei(1:inlen))) if(inlen.gt.ioutlen)then call jun(4,'*uppers* input longer than output') inlen=ioutlen endif endif uppers=' ' do 10 i10=1,inlen,1 let=linei(i10:i10) ilet=ichar(let) C lowercase a-z in ASCII is 97 to 122 C uppercase a-z in ASCII is 65 to 90 if( (ilet.ge.97) .and. (ilet.le.122))then C convert lowercase a-z to uppercase a-z uppers(iout:iout)=char(ilet-32) else C character is not an uppercase a-z, just put it in output uppers(iout:iout)=let endif iout=iout+1 10 continue return end C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- C A footnote: it is easy to make functions that do what RETREV and string_to_real C do, making very compact parsing: C C IVAL=IGET('mycommand_i') C C GIVEN KEYWORD, RETURN SINGLE INTEGER VALUE (ZERO ON ERROR) FUNCTION IGET(KEYWORD) CHARACTER*(*) KEYWORD CHARACTER*255 VALUE CALL RETREV(KEYWORD,VALUE,LEN,IER) CALL string_to_real(VALUE,ANUMBER,IER) IGET=ANUMBER+0.5 RETURN END FUNCTION RGET (KEYWORD) ! GIVEN KEYWORD, RETURN SINGLE REAL VALUE (ZERO ON ERROR) CHARACTER ( * ) KEYWORD CHARACTER(255) VALUE CALL RETREV (KEYWORD, VALUE, LEN, IER) CALL string_to_real (VALUE(:LEN), ANUMBER, IER) RGET = ANUMBER RETURN END LOGICAL FUNCTION LGET (KEYWORD) ! GIVEN KEYWORD, RETURN LOGICAL VALUE CHARACTER ( * ) KEYWORD CHARACTER(255) VALUE CHARACTER(255) UPPERS EXTERNAL UPPERS CALL RETREV (KEYWORD, VALUE, LEN, IER) VALUE=UPPERS(VALUE) IF(VALUE(:LEN).EQ.'')THEN LGET=.TRUE. ELSEIF(VALUE(:LEN).EQ.'#N#')THEN LGET=.FALSE. ELSEIF(VALUE(:1).EQ.'T')THEN LGET=.TRUE. ELSEIF(VALUE(:1).EQ.'F')THEN LGET=.FALSE. ELSEIF(VALUE(:2).EQ.'.T')THEN LGET=.TRUE. ELSEIF(VALUE(:2).EQ.'.F')THEN LGET=.FALSE. ELSE VALUE='*LGET* BAD LOGICAL VALUE '//KEYWORD(:JULEN(KEYWORD)) CALL JUN(4,VALUE) LGET=.FALSE. ENDIF RETURN END C=======================================================================-------- C()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() C=======================================================================-------- subroutine get_command_arguments(string,ilen,ier) C @(#) append all command-line arguments using getarg() and iargc() C quick sample for making a get_command_arguments for g77 C does not check if string goes over 1024 C assumes string length of zero OK C never sets ier character*(*) string character*1024 arg integer i string=' ' ier=0 ilen=0 if(iargc().eq.0)return call getarg(1,string) do 10 i10=2,iargc() call getarg(i10,arg) string=string(:julen(string))//' '//arg(:julen(arg)) 10 continue ilen=julen(string) return end