src/linp.f

Fortran project SIMRES, source module src/linp.f.

Source module last modified on Thu, 10 Mar 2005, 15:03;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


#///////////////////////////////////////////////////////////////////////////
#////                                                                   //// 
#////  LINP - v.1.2, (c) J.Saroun, 1999-2001                            ////
#////                                                                   //// 
#////  Universal command line interpreter                               //// 
#////                                                                   //// 
#////                                                                   //// 
#///////////////////////////////////////////////////////////////////////////
#////
#////
#////  Usage:
#////
#////  CALL LINPSET(NLINES,' PROMPT',COMMANDS,HINTS)
#////   ..... to set the prompt, commands and hints 
#//// 
#////  LINE=LINPEXEC(ICOM,NPAR)
#////   ..... reads the input and returns command number(ICOM), 
#/////        number of following parameters (NPAR)
#////         and the rest of the input string after the command (LINE)
#//// 
#////  LINE=FUNCTION LINPEXECSTR(SCOMM,ICOM,NPAR)
#////  .....  as LINPEXEC, but treats the string SCOMM instead of std. input
#//// 
#////  CALL LINPGETIO(IN,OUT,ERR), LINPSETIO(IN,OUT,ERR) 
#////   .... get or set the inout, output and error unit numbers
#//// 
#////
#///////////////////////////////////////////////////////////////////////////

#     ---------------------------------------------------
      integer*4 FUNCTION ORDCOM(what,commands,ncmd)
#     returns ordinal number of command
#     copy of GETICOM from "linp", but with var 'commands' argument      
#     ---------------------------------------------------
      implicit none
      character*(*) what
      integer*4 i,l,ipos,nc,ncmd
      character*(*) commands(ncmd)

      ipos=1
      nc=0
      ORDCOM=0
      call FINDPAR(what,1,ipos,l)      
      if (l.le.0) return
      call MKUPCASE(what(ipos:ipos+l-1))
      do i=1,ncmd
        if (index(commands(i),what(ipos:ipos+l-1)).eq.1) then
          ORDCOM=i  
          nc=nc+1
        endif
        if (nc.gt.1) then
           ORDCOM=-3     ! ambiguous command
           return  
        endif            
      enddo
      
      end    


#---------------------------------------------------
      integer*4 FUNCTION GETICOM(what)
# returns ordinal number of command 
# command not found  ... return 0
# ambiguous command  ... return -3
#---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      character*(*) what
      integer*4 i,l,ipos,nc,i1,i2
      character*5 cm

      ipos=1
      nc=0
      GETICOM=0
      call FINDPAR(what,1,ipos,l)
      if (l.gt.5) l=5
      
      if (l.le.0) return
      call MKUPCASE(what(ipos:ipos+l-1))
      do i=1,linp_nc
        cm=linp_c(i)
        call MKUPCASE(cm)
        if (index(cm,what(ipos:ipos+l-1)).eq.1) then
          GETICOM=i  
          nc=nc+1
          i1=1
          call FINDPAR(cm,1,i1,i2)
          if (cm(i1:i1+i2-1).eq.what(ipos:ipos+l-1)) return             
        endif
      enddo
      if (nc.gt.1) then
           GETICOM=-3     ! ambiguous command
           return  
      endif            
      
      end    

#     ---------------------------------------------------
      SUBROUTINE LINPGETIO(in,out,err)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 in,out,err
        in=linp_in
        out=linp_out
        err=linp_err
      end  


#     ---------------------------------------------------
      SUBROUTINE LINPSETIO(in,out,err)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 in,out,err
        linp_in=in
        linp_out=out
        linp_err=err
        linp_eof=0
      end  

#     ---------------------------------------------------
      SUBROUTINE LINPSET(nc,prompt,commands,hints)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 nc,i,dimc,dimh
      character*(*) commands(nc)
      character*(*) hints(nc),prompt
      
      call BOUNDS(prompt,i,linp_np)
      if (i+linp_np-1.gt.20) linp_np=21-i
      linp_p=prompt(1:i+linp_np-1)
# if nc=0, only prompt can be set up
      if (nc.le.0) return 
      dimc=len(commands(1))      
      dimh=len(hints(1))
      linp_nc=nc      
      if (dimc.gt.5) dimc=5
      if (dimh.gt.60) dimh=60
      if (linp_nc.gt.linp_dim) linp_nc=linp_dim
      do i=1,linp_nc
        linp_c(i)=commands(i)(1:dimc)
        linp_h(i)=hints(i)(1:dimh)
#        write(*,*) i,' ',linp_c(i),'  ',linp_h(I)
      enddo
      
      end  

#---------------------------------------------------
      character*(*) FUNCTION LINPEXEC(icom,npar)
# read a string from input and treat through LINPEXECSTR    
# output:  
#    ICOM: command ID
#    NPAR: number of command arguments
# return: command with arguments
# NOTE:
# if end of input file => ICOM=-4
#---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom,npar,ll
      character*128 line,LINPEXECSTR
      character*1 ch
      
1     format(a)
2     format(a,$)
10    if (linp_in.eq.5) write(linp_out,2) linp_p(1:linp_np)// '> ' 
            
      if (linp_eof.gt.0) goto 20
      read(linp_in,1,end=20) line
      ch=line(1:1)
      if (ch.eq. '#'.or.ch.eq. ' '.or.ch.eq.char(0)) goto 10
      if (line(1:1).eq. '#') goto 10
      ll=len(line)
#      IF (linp_in.NE.5) WRITE(linp_out,1) linp_p(1:linp_np)//
#     &   '> '//LINE(1:LL)
      LINPEXEC=LINPEXECSTR(line(1:ll),icom,npar)            
      if (icom.eq.-3) goto 10
      return
      
20    LINPEXEC= 'EOF'
#      write(*,*) 'linpexec: EOF'
      npar=0
      icom=-4
      end             
           
#---------------------------------------------------
      character*(*) FUNCTION LINPEXECSTR(scomm,icom,npar)
#  Treat command string 
#  input:   
#    SCOMM ... command string
#  output:  
#    ICOM: command ID
#    NPAR: number of command arguments
#  return: command with arguments
#  NOTE:
#  - ICOM=-5 ... command is an integer => return this integer as NPAR
#  - ICOM=-4 ... end of input file
#  - ICOM=-3 ... ambiguous command 
#  - ? gives a list of commands with hints
#  - 
#---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom,i,j,k,l,ip,ll,GETICOM,npar
      character*128 line
      character*(*) scomm
      logical*4 IsInteger
      
      data linp_in,linp_out,linp_err /5,6,7/
      data linp_np,linp_p /4, 'LINP'/

1     format(a)
#3     FORMAT(I)
      l=len(scomm)
      line=scomm(1:l)
            
#      READ(linp_in,1) LINE

#// try first, whether the input is integer 
#// if yes, return it as string, and in NPAR as value    
      if (IsInteger(line(1:l))) then
        read(line(1:l),*,err=20) i
        write(LINPEXECSTR,*) i
        icom=-5
        npar=i        
        return
      endif
            
20    icom=GETICOM(line)      ! find command number 
      ll=len(line)      
      if (icom.eq.-3) write(linp_err,1)  'Ambiguous command !'
      if (icom.lt.0) return
      
      k=1
      call FINDPAR(line,1,k,l)
      if (l.eq.0) return   ! line was empty
      if (icom.gt.0) then
        call BOUNDS(line(k+l:ll),ip,i)
        ip=ip+k+l-1
        LINPEXECSTR=line(ip:ip+i-1)    ! return string with parameters
        npar=0
        do while (l.gt.0)
          k=k+l
          call FINDPAR(line,1,k,l)
          if (l.gt.0) npar=npar+1          
        enddo
        return
      else if (icom.eq.0) then
        if (line(1:k).eq. '?') then
           k=k+l      
           call FINDPAR(line,1,k,l)
           i=GETICOM(line(k:k+l-1))
           if (i.gt.0) then
              if (linp_h(i) .ne. ' ') then 
               write(linp_out,*) linp_c(i)// '  '//linp_h(i)
              endif 
           else
               do j=1,linp_nc
                 if (linp_h(j).ne. ' ') then 
                   write(linp_out,*) linp_c(j)// '  '//linp_h(j)
                 endif 
               enddo
               write(linp_out,*)  'LIST   list values'
               write(linp_out,*)  'QUIT   quit this menu'
           endif
        else
           call MKUPCASE(line(1:k))
           if (index( 'QUIT',line(1:k)).eq.1) then
              LINPEXECSTR= 'QUIT'
              npar=0
              return
           else if (index( 'LIST',line(1:k)).eq.1) then
              LINPEXECSTR= 'LIST'
              npar=0
              return
           else if (index( 'PAUSE',line(1:5)).eq.1) then
              LINPEXECSTR= 'PAUSE'
              call DOPAUSE
              npar=0
              return
           else if (index( 'ECHO',line(1:4)).eq.1) then
              LINPEXECSTR= 'ECHO'
              call DOECHO
              npar=0
              return
           else
              write(linp_out,*)  'type ? for help'        
           endif
         endif
       endif
       LINPEXECSTR= ' '
       npar=0
       end

#--------------------------------
      SUBROUTINE DOPAUSE
# stop & wait for enter     
#--------------------------------
      implicit none
      INCLUDE 'linp.inc'
      character*1 ch
      
1     format( ' press ENTER ...',$)
2     format(a)
      write(linp_out,1) 
      read(*,2) ch
      write(linp_out,*) 
      
      if (ch.eq. 'q'.or.ch.eq. 'Q') linp_eof=1
      end
      
#--------------------------------
      SUBROUTINE DOECHO
# copy input to output until END - useful in batch files    
#--------------------------------
      implicit none
      INCLUDE 'linp.inc'
      character*128 comm,s
      integer*4 is,il
      logical*4 bk
            
2     format(a)
      
      bk=.false.
      write(linp_out,*)
      do while(.not.bk)
        read(linp_in,2,end=20) comm
        call BOUNDS(comm,is,il)
        s=comm(is:is+il-1)
        call MKUPCASE(s)
        bk=(il.eq.3.and.s(1:il).eq. 'END')
        if (.not.bk) write(linp_out,*) comm(is:is+il-1)
      enddo    
      return      
20    write(linp_out,*)  'ECHO command: END statement is missing'
      call DOPAUSE
      end

#     ---------------------------------------------------
      character*(*) FUNCTION GETCOM(icom)
#     returns ICOM-th command name      
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom
      if (icom.gt.0.and.icom.le.linp_nc) then
         GETCOM=linp_c(icom)
      else if (icom.eq.-1) then
         GETCOM= 'QUIT'         
      else if (icom.eq.-2) then
         GETCOM= '?'
      else       
         GETCOM= ' '
      endif
      end

#     ---------------------------------------------------
      character*(*) FUNCTION GETHINT(icom)
#     ---------------------------------------------------
      implicit none
      INCLUDE 'linp.inc'
      integer*4 icom
      if (icom.gt.0.and.icom.le.linp_nc) then
         GETHINT=linp_h(icom)
      else if (icom.eq.-1) then
         GETHINT= 'Quit interpreter'         
      else if (icom.eq.-2) then
         GETHINT= 'Show hints'
      else if (icom.eq.-3) then
         GETHINT= 'Ambiguous command'
      else       
         GETHINT= ' '
      endif
      end