src/restraxcon.f

Fortran project RESTRAX, source module src/restraxcon.f.

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
#