Source module last modified on Sat, 6 May 2006, 15:54;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#---------------------------------------------
# RESTRAX console interface
# $Author: saroun $
# $Id: restraxcon.f,v 1.4 2006/05/06 13:54:58 saroun Exp $
#----------------------------------------------
PROGRAM RESTRAX
call RESTRAX_MAIN
end
#-------------------------------------
SUBROUTINE RESTRAX_MAIN
# Main unit for console application
# Should be called by the main procedure
#-------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'linp.inc'
INCLUDE 'restrax_cmd.inc'
character*128 line,s,UPCASE
character*1 ch
integer*4 is,il
logical*4 echomode
data echomode /.false./
1 format(a)
2 format(a,$)
3 format( ' press ENTER ...',$)
# initialization
cmdmode=1 ! command-line mode
call RESINIT
call CMD_INIT
# run
do while (goend.eq.0)
10 if (linp_in.eq.5) write(linp_out,2) linp_p(1:linp_np)// '> '
if (linp_eof.gt.0) goto 20
read(sinp,1,end=20) line ! treat EOF
call BOUNDS(line,is,il)
s=UPCASE(line(is:is+il-1))
# write(*,*) S(IS:IS+IL-1)//'>',ECHOMODE
# echo mode => copy input to output
if (echomode) then
if (s(is:is+il-1).eq. 'END') then ! END ECHO
echomode=.false.
else
write(linp_out,1) line(is:is+il-1)
# WRITE(linp_out,*) S(IS:IS+IL-1)//'> ',ECHOMODE
endif
# ECHO
else if (s(is:is+il-1).eq. 'ECHO') then
echomode=.true.
# PAUSE
else if (s(is:is+il-1).eq. 'PAUSE') then
write(linp_out,3)
read(*,1) ch
write(linp_out,*)
if (ch.eq. 'q'.or.ch.eq. 'Q') goto 20
# handle input except empty lines and # comments
else if (il.gt.0.and.line(1:1).ne. '#') then
call CMD_HANDLE(line(is:is+il-1))
endif
if (goend.eq.0) goto 10
# handle requests on I/O reset to STDIN/STDOUT
20 call REINP( ' ')
call LINPSETIO(sinp,sout,smes)
enddo
# finalization
call RESEND
end
#-----------------------------------------------------------------------
SUBROUTINE DLG_SETPATH(sarg,prompt,answer,iread,pname)
# Prompt for a valid pathname and store result in PNAME
# INPUT:
# sarg ... input string with the path name
# prompt ... input prompt text, results in: > prompt [default] : _
# answer ... answer text, results in: > answer <pname>
# iread ... if>1, read the pathname interactively
# RETURN:
# pname ... resulting pathname
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg,prompt,answer,pname
integer*4 iread
character*128 fn,ss
integer*4 is,il,isf,ilf,ii,ll
logical*4 askname
1 format(a, ' [',a, '] : ',$)
2 format(a, ' [current directory] : ',$)
3 format(a, ' ',a)
4 format(a)
call BOUNDS(sarg,isf,ilf)
call BOUNDS(pname,is,il)
# ask for filename interactively ?
askname=(ilf.le.0.or.iread.gt.0)
fn= ' '
if (ilf.gt.0) fn=sarg(isf:isf+ilf-1)
if (askname) then ! get filename interactively
if (il.gt.0) then
write(sout,1) prompt(1:len_trim(prompt)),pname(is:is+il-1)
else
write(sout,2) prompt(1:len_trim(prompt))
endif
read(sinp,4) ss
call BOUNDS(ss,ii,ll)
if (ll.gt.0) then ! use default
fn=ss(ii:ii+ll-1)
else
fn=pname(is:is+il-1)
endif
endif
call BOUNDS(fn,is,il)
# Interpret input, ensure that ending delimiter is present
if ((il.le.0).or.
* (il.eq.1.and.fn(is:is+il-1).eq. '.').or.
* (il.eq.2.and.fn(is:is+il-1).eq. '.'//pathdel)) then
pname= ' '
write(sout,3) answer(1:len_trim(answer)), 'current directory'
return
else if(fn(is+il-1:is+il-1).ne.pathdel) then
pname=fn(is:is+il-1)//pathdel
else
pname=fn(is:is+il-1)
endif
write(sout,3) answer(1:len_trim(answer)),pname(1:il)
end
#-------------------------------------------------------------------
SUBROUTINE DLG_FILEOPEN(fname,fpath,fext,iread,isil,ires,fres)
# Get a fully qualified filename, test existence, etc.
# INPUT:
# fname ... filename
# fext ... default extension
# fpath ... colon delimited list of search directories
# iread ... if>1, read the filename interactively
# isil ... silence level, if isil>0 => no message
# RETURN:
# fres ... resulting filename (incl. path)
# IRES>0 ... ord. number of the path string from fpath
# IRES=0 ... not found
#-------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) fname,fext,fpath,fres
integer*4 iread,isil,ires
character*256 fn,s,ss
integer*4 isf,ilf,is,il,ii,ll,lext,TRUELEN
logical*4 apext,askname
1 format( ' Open file [',a, '] : ',$)
2 format( ' Open file : ',$)
4 format(a)
#11 FORMAT(' DLG_OPEN: ',I4,' <',a,'>')
# write(*,11) iread,FNAME(1:LEN_TRIM(FNAME))
ires=0
lext=TRUELEN(fext)
call BOUNDS(fname,isf,ilf)
# append extension ?
apext=(lext.gt.0.and.(index(fname(isf:isf+ilf-1), '.').le.0))
# ask for filename interactively ?
askname=(ilf.le.0.or.iread.gt.0)
# format prompt
s= ' '
if (apext) then
if (ilf.gt.0) then
s=fname(isf:isf+ilf-1)// '.'//fext(1:lext)
else
s= '*.'//fext(1:lext)
endif
else if (ilf.gt.0) then
s=fname(isf:isf+ilf-1)
endif
call BOUNDS(s,is,il)
# format the file name
fn= ' '
if (ilf.gt.0) fn=fname(isf:isf+ilf-1)
if (askname) then ! get filename interactively
if (il.gt.0) then
write(sout,1) s(is:is+il-1)
else
write(sout,2)
endif
read(sinp,4) ss
call ILLNameParse(ss,1)
call BOUNDS(ss,ii,ll)
if (ll.le.0) then ! use default
if (il.gt.0) then
fn=s(is:is+il-1)
else
goto 99 ! no filename, exit
endif
else
fn=ss(ii:ii+ll-1)
endif
else
call ILLNameParse(fn,1)
endif
il=len_trim(fn)
if (il.le.0) goto 99
# append extension when required
apext=(lext.gt.0.and.index(fn, '.').le.0)
if (apext) fn=fn(1:il)// '.'//fext(1:lext)
# write(*,11) IL,FN(1:LEN_TRIM(FN))
# find the first file that exists in a directory listed in fpath
call CHECKRESFILE(fn,fpath,isil,ires,fres)
# write(*,11) IRES,FRES(1:LEN_TRIM(FRES))
return
99 ires=0
end
#--------------------------------------------------------------
SUBROUTINE DLG_FILESAVE(fname,fpath,fext,iread,iover,ires,fres)
# Get a fully qualified filename for saving, test overwrite, etc.
# INPUT:
# fname ... filename
# fpath ... target directory
# fext ... default extension
# iread ... if>1, read the filename interactively
# iover ... if>1, dont ask for overwriting the file
# RETURN:
# fres ... resulting filename (incl. path)
# IRES>0 ... open possible, fres is the full pathname
# IRES=0 ... cancel
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) fname,fext,fpath,fres
integer*4 iread,iover,ires
character*256 ffn,fn,ss,s
character*1 ch
integer*4 isf,ilf,is,il,ii,ll,lres,lext,j
logical*4 log1,apext,askname
1 format( ' Save to file [',a, '] : ',$)
2 format( ' Save to file : ',$)
4 format(a)
5 format( 'File ',a, ' already exists. Overwrite ? [y|n] ',$)
ires=0
lres=len(fres)
lext=len_trim(fext)
call BOUNDS(fname,isf,ilf)
# append extension ?
apext=(lext.gt.0.and.index(fname(isf:isf+ilf-1), '.').le.0)
# ask for filename interactively ?
askname=(ilf.le.0.or.iread.gt.0)
# format prompt
s= ' '
if (apext) then
if (ilf.gt.0) then
s=fname(isf:isf+ilf-1)// '.'//fext(1:lext)
else
s= '*.'//fext(1:lext)
endif
else if (ilf.gt.0) then
s=fname(isf:isf+ilf-1)
endif
call BOUNDS(s,is,il)
# format the file name
fn= ' '
if (ilf.gt.0) fn=fname(isf:isf+ilf-1)
if (askname) then ! get filename interactively
if (s.ne. ' ') then
write(sout,1) s(is:is+il-1)
else
write(sout,2)
endif
read(sinp,4) ss
call BOUNDS(ss,ii,ll)
if (ll.le.0) then ! use default
if (ilf.gt.0) then
fn=fname(isf:isf+ilf-1)
else
goto 99 ! no filename, exit
endif
else
fn=ss(ii:ii+ll-1)
endif
endif
il=len_trim(fn)
if (il.le.0) goto 99
# append extension when required
apext=(lext.gt.0.and.index(fn, '.').le.0)
if (apext) fn=fn(1:il)// '.'//fext(1:lext)
# prepend the path name
call BOUNDS(fpath,is,il)
j=is+il-1
if (il.gt.0.and.fpath(j:j).ne.pathdel) then
ffn=fpath(is:j)//pathdel//fn(1:len_trim(fn))
else if (il.gt.0) then
ffn=fpath(is:j)//fn(1:len_trim(fn))
else
ffn=fn(1:len_trim(fn))
endif
ll=len_trim(ffn)
if (ll.gt.lres) ll=lres
fres=ffn(1:ll)
# check for overwrite
ch= 'y'
if (iover.gt.0.and.sinp.eq.5) then ! automatic overwrite for non-std input
inquire(file=ffn(1:ll),exist=log1)
if (log1) then ! ask before overwrite
20 write(sout,5) fn(1:len_trim(fn))
read(sinp,4,err=20) ch
if (ch.eq. 'Y') ch= 'y'
endif
endif
if (ch.ne. 'y') goto 99
ires=1
return
99 ires=0
end
#--------------------------------------------------------------
SUBROUTINE DLG_INPUT(labels,values,idef)
# Dialog for numerical input.
# INPUT:
# labels ... a string with value names, items are delimited by :
# values ... if idef>0, should contain default values
# idef ... if >0, prompt inlcudes default values accepted by <enter>
# RETURN:
# values ... real*8 array with return values
# NOTE! No check is made on values array dimension
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) labels
real*8 values(*)
integer*4 idef
character*64 s,s1
character*128 prompt
integer*4 is,il,is1,il1,ilp,ip,itry,ios
1 format(a, ' : ',$)
3 format(a)
4 format( 'invalid number format, ',$)
6 format( 'try again')
8 format( 'no input')
20 format(a)
21 format(a, ' [',a, ']')
22 format(g12.4)
il=1
ip=0
do while (il.ge.0)
#// get next value name
ip=ip+1
call FINDSTRPAR(labels, ':',ip,is,il)
#// format prompt
if (il.gt.0) then
s=labels(is:is+il-1)
ilp=il
else
s= 'input number'
ilp=12
endif
if (idef.gt.0) then
write(s1,22) values(ip)
call BOUNDS(s,is1,il1)
write(prompt,21) s(1:ilp),s1(is1:is1+il1-1)
else
write(prompt,20) s(1:ilp)
endif
ilp=len_trim(prompt)
if (ilp.gt.128) ilp=128
if (il.ge.0) then
#// read data and check validity
itry=0
10 itry=itry+1
write(sout,1) prompt(1:ilp)
read(sinp,3) s
il1=len_trim(s)
if (il1.gt.0) read(s,*,iostat=ios,err=11) values(ip)
#// validate input
11 if (ios.ne.0) then ! format error
write(sout,4)
endif
if (itry.lt.5.and.ios.ne.0) then ! 5 attempts to enter a valid number
write(sout,6)
goto 10
else if (ios.ne.0) then
write(sout,8)
endif
endif
enddo
end
#--------------------------------------------------------------
SUBROUTINE DLG_INTEGER(label,ivalue,idef,imin,imax)
# Single integer number input, with range checking.
# INPUT:
# label ... a string with value name
# ivalue ... if idef>0, should contain default value
# idef ... if >0, prompt inlcudes the default value accepted by <enter>
# imin,imax ... limits (inclusive)
# RETURN:
# ivalue ... integer*4 return value
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) label
integer*4 ivalue,idef,imin,imax
character*64 s,s1,s2,s3
character*128 prompt
integer*4 is1,is2,is3,il,il1,il2,il3,ilp,itry,ios
1 format(a, ' : ',$)
3 format(a)
4 format( 'invalid number format, ',$)
5 format( 'value outside limits, ',$)
6 format( 'try again')
8 format( 'no input')
20 format(a, ' (',a, ' .. ',a, ') ')
21 format(a, ' (',a, ' .. ',a, ') [',a, ']')
22 format(i8)
prompt= ' '
#// format prompt
write(s1,22) imin
write(s2,22) imax
call BOUNDS(s1,is1,il1)
call BOUNDS(s2,is2,il2)
il=len_trim(label)
if (il.gt.0) then
s=label(1:il)
else
s= 'input number'
il=12
endif
if (idef.gt.0) then
write(s3,22) ivalue
call BOUNDS(s3,is3,il3)
write(prompt,21) s(1:il),s1(is1:is1+il1-1),
& s2(is2:is2+il2-1),s3(is3:is3+il3-1)
else
write(prompt,20) s(1:il),s1(is1:is1+il1-1),
& s2(is2:is2+il2-1)
endif
ilp=len_trim(prompt)
if (ilp.gt.128) ilp=128
#// read data and check validity
itry=0
10 itry=itry+1
write(sout,1) prompt(1:ilp)
read(sinp,3) s
il1=len_trim(s)
ios=0
if (il1.gt.0) read(s,*,iostat=ios,err=11) ivalue
#// validate input
11 if (ios.ne.0) then ! format error
write(sout,4)
else if (ivalue.lt.imin.or.ivalue.gt.imax) then ! range error
ios=1
write(sout,5)
endif
if (itry.lt.5.and.ios.ne.0) then ! 5 attempts to enter a valid number
write(sout,6)
goto 10
else if (ios.ne.0) then
write(sout,8)
endif
end
#--------------------------------------------------------------
SUBROUTINE DLG_DOUBLE(label,value,idef,dmin,dmax)
# Single real*8 number input, with range checking.
# INPUT:
# label ... a string with value name
# value ... if idef>0, should contain default value
# idef ... if >0, prompt inlcudes the default value accepted by <enter>
# dmin,dmax ... limits (inclusive)
# RETURN:
# value ... real*8 return value
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) label
integer*4 idef
real*8 value,dmin,dmax
character*64 s,s1,s2,s3
character*128 prompt
integer*4 is1,is2,is3,il,il1,il2,il3,ilp,itry,ios
1 format(a, ' : ',$)
3 format(a)
4 format( 'invalid number format, ',$)
5 format( 'value outside limits, ',$)
6 format( 'try again')
8 format( 'no input')
20 format(a, ' (',a, ' .. ',a, ')')
21 format(a, ' (',a, ' .. ',a, ') [',a, ']')
#22 format(F10.4)
prompt= ' '
#// format prompt
call FLOAT2STR(dmin,s1)
call FLOAT2STR(dmax,s2)
# WRITE(S1,22) dmin
# WRITE(S2,22) dmax
call BOUNDS(s1,is1,il1)
call BOUNDS(s2,is2,il2)
il=len_trim(label)
if (il.gt.0) then
s=label(1:il)
else
s= 'input number'
il=12
endif
if (idef.gt.0) then
call FLOAT2STR(value,s3)
# write(S3,22) value
call BOUNDS(s3,is3,il3)
write(prompt,21) s(1:il),s1(is1:is1+il1-1),
& s2(is2:is2+il2-1),s3(is3:is3+il3-1)
else
write(prompt,20) s(1:il),s1(is1:is1+il1-1),
& s2(is2:is2+il2-1)
endif
ilp=len_trim(prompt)
if (ilp.gt.128) ilp=128
#// read data and check validity
itry=0
10 itry=itry+1
write(sout,1) prompt(1:ilp)
read(sinp,3) s
il1=len_trim(s)
ios=0
if (il1.gt.0) read(s,*,iostat=ios,err=11) value
#// validate input
11 if (ios.ne.0) then ! format error
write(sout,4)
else if (value.lt.dmin.or.value.gt.dmax) then ! range error
ios=1
write(sout,5)
endif
if (itry.lt.5.and.ios.ne.0) then ! 5 attempts to enter a valid number
write(sout,6)
goto 10
else if (ios.ne.0) then
write(sout,8)
endif
end
#--------------------------------------------------------------
SUBROUTINE DLG_STRING(label,value,idef)
# Single string input
# INPUT:
# label ... a string with value name
# value ... if idef>0, should contain default value
# idef ... if >0, prompt inlcudes the default value accepted by <enter>
# RETURN:
# value ... return string value
# NOTE: must not channge the value on default response (ENTER)
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) label,value
integer*4 idef
character*128 s,prompt
integer*4 is1,il,il1,ilp
1 format(a, ' : ',$)
2 format(a, ' [',a, ']')
3 format(a)
prompt= ' '
#// format prompt
il=len_trim(label)
if (il.gt.0) then
s=label(1:il)
else
s= 'input string'
il=12
endif
if (idef.gt.0) then
call BOUNDS(value,is1,il1)
write(prompt,2) s(1:il),value(is1:is1+il1-1)
else
prompt=s(1:il)
endif
ilp=len_trim(prompt)
if (ilp.gt.128) ilp=128
#// read value
write(sout,1) prompt(1:ilp)
read(sinp,3) s
il1=len_trim(s)
il1=min(il1,len(value)) ! check for value size
if (il1.gt.0) value=s(1:il1)
end
#--------------------------------------------------------------
SUBROUTINE DLG_RESPLOT(labels,arg,narg,sarg)
# Dialog for 2D-plot settings: resoluton function projections
# By convention, output is stored in the ARG(11..) array and GRFSTR string
# INPUT:
# labels ... axes names, delimited by :
# RETURN:
# ARG(1..2) ... selected pair of axes
# ARG(3..4) ... limits for x-axis
# ARG(5..6) ... limits for y-axis
# SARG ... a plot caption
# Dialog arguments (in non-interactive mode):
# DLGARG(1..6) ... copied to ARG
# DLGSTR(1) ... copied to SARG (plot caption)
#--------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'res_grf.inc'
INCLUDE 'restrax_cmd.inc'
character*(*) labels,sarg
integer*4 narg
real*8 arg(narg)
character*128 comment
integer*4 ix,iy
real*8 xmin,xmax,ymin,ymax
integer*4 i,is,il,ip
1 format(i2, ') ',a)
2 format( 'select projection (X,Y): ',$)
3 format( 'limits for ',a, ' [min max] : ',$)
4 format( 'comment: ',$)
5 format(a)
6 format( 'incorrect range, try again ...')
#// non-interactive case -> use the argument array
if (cmdmode.eq.0) then
call BOUNDS(dlgstr(1),is,il)
if (il.gt.len(sarg)) il=len(sarg)
sarg=dlgstr(1)(is:is+il-1)
do i=1,6
arg(i)=dlgarg(i)
enddo
return
endif
#// interactive mode:
#// get number of axes available
il=1
ip=0
do while (il.gt.0)
call FINDSTRPAR(labels, ':',ip+1,is,il)
if (il.gt.0) then
ip=ip+1
write(smes,1) ip,labels(is:is+il-1)
endif
enddo
#// get projection axes
10 write(smes,2)
read(sinp,*,err=10) ix,iy
if (ix.lt.0.or.ix.gt.ip.or.iy.lt.0.or.iy.gt.ip) goto 10
#// get limits
call FINDSTRPAR(labels, ':',ix,is,il)
20 write(sout,3) labels(is:is+il-1)
read(sinp,*,err=20) xmin,xmax
if (xmin.ge.xmax) then
write(smes,6)
goto 20
endif
call FINDSTRPAR(labels, ':',iy,is,il)
30 write(sout,3) labels(is:is+il-1)
read(sinp,*,err=30) ymin,ymax
if (ymin.ge.ymax) then
write(smes,6)
goto 30
endif
write(smes,4)
read(sinp,5) comment
call BOUNDS(comment,is,il)
if (il.gt.len(sarg)) il=len(sarg)
sarg=comment(is:is+il-1)
arg(1)=ix
arg(2)=iy
arg(3)=xmin
arg(4)=xmax
arg(5)=ymin
arg(6)=ymax
end
# $Log: restraxcon.f,v $
# Revision 1.4 2006/05/06 13:54:58 saroun
# some fixes for plotting: PLOT SCAN without histogram
#
# Revision 1.3 2005/07/13 15:17:35 saroun
# *** empty log message ***
#
# Revision 1.2 2005/07/13 15:15:55 saroun
# *** empty log message ***
#
# Revision 1.1.1.1 2005/07/13 14:20:33 saroun
#
#
# Revision 1.3 2005/07/12 19:24:13 saroun
# another test cvs
#
# Revision 1.2 2005/07/12 19:21:50 saroun
# testing cvs keywords
#