      subroutine attach(pid,ier)
      integer pid
      integer ier
      integer status
      integer lib$attach
      status = lib$attach(pid)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine Build_file(IN,NAME,TYP,OUTFINAL,LO)
      character IN*(*)         !I: inputfilename
      character NAME*(*)       !I: name if inputfilename is nameless
      character TYP*(*)        !I: type if inputfilename is typeless
      character OUTFINAL*(*)   !O: result
      integer   LO             !O: length out
      integer   length
      character string*256
      integer   ls
      integer   ip
      character out*256
      ip = 0
      call filescan(IN,'PATH',string,ls)
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      call filescan(IN,'NAME',string,ls)
      if(ls.eq.0) then
        ls = length(NAME)
        if(ls.gt.0) string = NAME(1:ls)
      endif
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      call filescan(IN,'TYPE',string,ls)
      if(ls.le.1) then
        if(length(TYP).eq.0) then
          string = '.'
          ls = 1
        else
          if(TYP(1:1).eq.'.') then
            string = TYP
          else
            string = '.'//TYP
          endif
          ls = length(string)
        endif
      endif
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      call filescan(IN,'VERSION',string,ls)
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      outfinal = out
      LO = ip
      return
      end
      subroutine build_file_type(IN,NAME,TYP,OUTFINAL,LO)
      character IN*(*)         !I: inputfilename
      character NAME*(*)       !I: name if inputfilename is nameless
      character TYP*(*)        !I: type
      character OUTFINAL*(*)   !O: result
      integer   LO             !O: length result
      integer   length
      character string*256
      integer   ls
      integer   ip
      character out*256
      ip = 0
      call filescan(IN,'PATH',string,ls)
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      call filescan(IN,'NAME',string,ls)
      if(ls.eq.0) then
        ls = length(NAME)
        if(ls.gt.0) string = name(1:ls)
      endif
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      if(length(TYP).eq.0) then
        string = '.'
        ls = 1
      else
        if(TYP(1:1).eq.'.') then
          string = TYP
        else
          string = '.'//TYP
        endif
        ls = length(string)
      endif
      if(ls.gt.0) then
        OUT(ip+1:) = string(1:ls)
        ip = ip + ls
      endif
      outfinal = out
      LO = ip
      return
      end
      character*12 function cputime()
      character sec2time*12
      real      second
      cputime = sec2time(second())
      return
      end
      subroutine create_directory(string,ier)
      character string*(*)
      integer   ier
      integer   lenstr
      integer   lib$create_dir
      integer   status
      integer   ls
      ls = lenstr(string)
      status = lib$create_dir(string(1:ls))
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine create_file(filename,unit,message,error)
      character filename*(*)
      integer   unit
      character message*(*)
      integer   error
      integer   lenstr
      integer   lf
      lf = lenstr(filename)
      call get_lun(unit,error)
      if(error.ne.0) then
        message = 'No free unit in create_file '//filename(1:lf)
        return
      endif
      open(unit=unit,file=filename(1:lf),status='new',
     1 carriagecontrol='list',iostat=error)
      if(error.ne.0) then
        call str_integer(error,'Error # creating '//filename(1:lf),
     1   message)
      else
        message = 'Created '//filename(1:lf)
      endif
      return
      end
      character*20 function datetime()
      call lib$date_time(datetime)
      return
      end
      subroutine DIRECTORY(instr,name1,name2,ier)
      integer   instr
      character name1*(*)
      character name2*(*)
      integer   ier
      integer   lib$find_file
      integer   lib$find_file_end
      integer   status
      integer   context
      integer   mask
      integer   i
      save context
      INCLUDE '($RMSDEF)'
      MASK = IBSET(0,1)
      ier = 1
      if(INSTR.eq.-1)  then
        status = lib$find_file_END(%ref(context))
        ier = 0
        return
      else
        if(INSTR.eq.0) then
          context = 0
        endif
10      continue
        status = lib$find_file(name1,name2,%ref(context),,,,%ref(mask))
        if(status.eq.RMS$_NORMAL) then
          ier = 0
        else if (status.eq.RMS$_PRV) then
          goto 10
        else
          ier = status
        endif
      endif
      return
      end ! directory
      subroutine editor(string,ier)
      character string*(*)
      integer   ier
      integer   lenstr
      integer   edt$edit
      integer   status
      integer   unit
      integer   iostat
      call get_lun(unit,ier)
      if(ier.ne.0) return
      ls = lenstr(string)
      open(unit=unit,file=string(1:ls),status='unknown',readonly,
     1 iostat=iostat)
      if(iostat.eq.0) close(unit)
      if(iostat.eq.0.or.iostat.eq.29) then ! 29=file does not exist
        status = edt$edit(string(1:ls),,,'sys$scratch:')
        if(.not.status) then
          ier = status
        else
          ier = 0
        endif
      else
        ier = iostat
      endif
      return
      end
      SUBROUTINE EVALUATE8(FORMULA,VALUE,ERRPOS,REASONRET)
      CHARACTER FORMULA*(*)
      REAL*8    VALUE
      INTEGER   ERRPOS
      CHARACTER REASONRET*(*)
      integer   length
      REAL*8    eval_EXPRESSION
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      integer   IFAC
      INTEGER   L
      integer   START
      REAL*8    F
      CHARACTER LINE*8
      COMMON/evl___FACTOR/IFAC,L(20),START(20),F(20),LINE(20)
      INTEGER   IEXP
      CHARACTER OPR
      REAL*8    E
      COMMON/evl___EXPRESSION/IEXP,OPR(20),E(20)
      INTEGER   ISIM
      CHARACTER OPS
      REAL*8    S
      real*8    S2
      COMMON/evl___SIMPLE/ISIM,OPS(20),S(20),S2(20)
      INTEGER   ITER
      REAL*8    T
      COMMON/evl___TERM/ITER,T(20)
      CHARACTER EOFLINE
      DATA EOFLINE /13/
      integer   i
      IFAC=0
      ISIM=0
      IEXP=0
      ITER=0
      POS=0
      ERR=0
      ERRPOS=0
      REASON=' '
      form = formula
 
      IF (form(1:1).EQ.'.') form='0'//form
      IF (form(1:1).EQ.'+') form=form(2:)
 
 
      do while (index(form,'**').gt.1)
        i=index(form,'**')
        form=form(1:i-1)//'^'//form(i+2:)
      enddo
      lf = length(form)
 
      CALL eval_NEXTCH
      VALUE=eval_EXPRESSION()
      IF (ERR.EQ.0.AND.CH.NE.EOFLINE) THEN
        ERR=POS
        REASON='UNEXPECTED CHARACTERS'
      ENDIF
      ERRPOS=ERR
      REASONRET=REASON
      RETURN
      END
      REAL*8 FUNCTION eval_EXPRESSION
      REAL*8    SIMPLE_EXPRESSION
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      INTEGER   IEXP
      CHARACTER OPR
      REAL*8    E
      COMMON/evl___EXPRESSION/IEXP,OPR(20),E(20)
      IEXP=IEXP+1
      eval_expression = 0.0  ! init
      IF (IEXP.GT.20) THEN
        REASON='TOO MUCH NESTING'
        ERR=POS
        RETURN
      ENDIF
      E(IEXP)=SIMPLE_EXPRESSION()
      IF (ERR.GT.0) RETURN
      DO WHILE (CH.EQ.'+'.OR.CH.EQ.'-')
        OPR(IEXP)=CH
        CALL eval_NEXTCH
        IF (OPR(IEXP).EQ.'+') THEN
          E(IEXP)=E(IEXP)+SIMPLE_EXPRESSION()
          IF (ERR.GT.0) RETURN
        ELSE
          E(IEXP)=E(IEXP)-SIMPLE_EXPRESSION()
          IF (ERR.GT.0) RETURN
        ENDIF
      ENDDO
      eval_EXPRESSION=E(IEXP)
      IEXP=IEXP-1
      RETURN
      END
      REAL*8 FUNCTION eval_FACTOR
      REAL*8    eval_EXPRESSION
      real*8    FUNC
      CHARACTER FORM*255
      INTEGER   POS
      integer   ERR
      CHARACTER CH
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      integer   IFAC
      INTEGER   L
      integer   START
      REAL*8    F
      CHARACTER LINE*8
      COMMON/evl___FACTOR/IFAC,L(20),START(20),F(20),LINE(20)
      integer   I
      CHARACTER FIRSTNAMECHARS*80
      character NAMECHARS*80
      DATA FIRSTNAMECHARS/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA NAMECHARS/'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$'/
      eval_factor = 0.0 ! init
      IFAC=IFAC+1
      IF (IFAC.GT.20) THEN
        REASON='TOO MUCH NESTING'
        ERR=POS
        RETURN
      ENDIF
      IF (CH.GE.'0'.AND.CH.LE.'9') THEN                        ! NUMBER
        START(IFAC)=POS
        DO WHILE (CH.LE.'9'.AND.CH.GE.'0')
          CALL eval_NEXTCH
        ENDDO
        IF (CH.EQ.'.') THEN
          CALL eval_NEXTCH
          DO WHILE (CH.LE.'9'.AND.CH.GE.'0')
            CALL eval_NEXTCH
          ENDDO
        ENDIF
        IF (CH.EQ.'E') THEN
          CALL eval_NEXTCH
          CALL eval_NEXTCH
          DO WHILE (CH.LE.'9'.AND.CH.GE.'0')
            CALL eval_NEXTCH
          ENDDO
        ENDIF
        READ(FORM(START(IFAC):POS-1),'(F<POS-START(IFAC)>.0)'
     1        ,ERR=90) F(IFAC)
        GOTO 80
90      CONTINUE
        REASON='ERROR IN CONSTANT.'
        ERR=POS
        RETURN
80      CONTINUE
      ELSE
        IF (CH.EQ.'(') THEN                                      ! EXPRESSIE
          CALL eval_NEXTCH
          F(IFAC)=eval_EXPRESSION()
          IF (ERR.GT.0) RETURN
          IF (CH.EQ.')') THEN
            CALL eval_NEXTCH
          ELSE
            REASON='")" EXPECTED'
            ERR=POS
            RETURN
          ENDIF
        ELSE
          IF (INDEX(FIRSTNAMECHARS,CH).EQ.0) THEN
            REASON='NUMBER/FUNC SYNTAX ERROR.'
            ERR=POS
            RETURN
          ENDIF
          START(IFAC)=POS
          DO WHILE (INDEX(NAMECHARS,CH).GT.0)
            CALL eval_NEXTCH
          ENDDO
          LINE(IFAC)=FORM(START(IFAC):POS-1)
          IF (CH.NE.'(') THEN
            REASON='VARIABLE NOT FOUND'
            ERR=POS
            RETURN
          ELSE
            CALL eval_NEXTCH
            F(IFAC)=eval_EXPRESSION()
            IF (ERR.GT.0) RETURN
            IF (CH.EQ.')') THEN
              CALL eval_NEXTCH
            ELSE
              REASON='")" EXPECTED'
              ERR=POS
              RETURN
            ENDIF
            IF (LINE(IFAC)(1:4).EQ.'TAND') THEN
              F(IFAC)=TAND(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'SIND') THEN
              F(IFAC)=SIND(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'COSD') THEN
              F(IFAC)=COSD(F(IFAC))
            ELSE IF (LINE(IFAC)(1:3).EQ.'SIN') THEN
              F(IFAC)=SIN(F(IFAC))
            ELSE IF (LINE(IFAC)(1:3).EQ.'COS') THEN
              F(IFAC)=COS(F(IFAC))
            ELSE IF (LINE(IFAC)(1:3).EQ.'TAN') THEN
              F(IFAC)=TAN(F(IFAC))
            ELSE IF (LINE(IFAC)(1:5).EQ.'ATAND') THEN
              F(IFAC)=ATAND(F(IFAC))
            ELSE IF (LINE(IFAC)(1:5).EQ.'ASIND') THEN
              IF (F(IFAC).LT.-1D0.OR.F(IFAC).GT.1D0) THEN
                REASON='ASIN-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=ASIND(F(IFAC))
            ELSE IF (LINE(IFAC)(1:5).EQ.'ACOSD') THEN
              IF (F(IFAC).LT.-1D0.OR.F(IFAC).GT.1D0) THEN
                REASON='ACOS-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=ACOSD(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'ATAN') THEN
              F(IFAC)=ATAN(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'ASIN') THEN
              IF (F(IFAC).LT.-1D0.OR.F(IFAC).GT.1D0) THEN
                REASON='ASIN-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=ASIN(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'ACOS') THEN
              IF (F(IFAC).LT.-1D0.OR.F(IFAC).GT.1D0) THEN
                REASON='ACOS-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=ACOS(F(IFAC))
            ELSE IF (LINE(IFAC)(1:4).EQ.'SQRT') THEN
              IF (F(IFAC).LT.0D0) THEN
                REASON='SQRT-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=SQRT(F(IFAC))
            ELSE IF (LINE(IFAC)(1:3).EQ.'EXP') THEN
              IF (F(IFAC).GT.85.6D0) THEN
                REASON='EXP-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=EXP(F(IFAC))
            ELSE IF (LINE(IFAC)(1:5).EQ.'LOG10') THEN
              IF (F(IFAC).LT.0D0) THEN
                REASON='LOG10-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=LOG10(F(IFAC))
            ELSE IF (LINE(IFAC)(1:3).EQ.'LOG') THEN
              IF (F(IFAC).LT.0D0) THEN
                REASON='LOG-ARGUMENT ERROR'
                ERR=POS
                RETURN
              ENDIF
              F(IFAC)=LOG(F(IFAC))
            ELSE
              REASON='UNKNOWN FUNCTION'
              ERR=POS
              RETURN
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      eval_FACTOR=F(IFAC)
      IFAC=IFAC-1
      RETURN
      END
      SUBROUTINE eval_NEXTCH
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      CHARACTER EOFLINE
      DATA EOFLINE /13/
      character TAB
      data TAB/9/
10    CONTINUE
      POS=POS+1
      IF (POS.LE.Lf) THEN
        CH=FORM(POS:POS)
      ELSE
        CH=EOFLINE
      ENDIF
      IF (CH.EQ.' '.OR.CH.EQ.TAB) GOTO 10
      RETURN
      END
      REAL*8 FUNCTION eval_TERM
      REAL*8    SIGNEDFACTOR
      real*8    EXP
      real*8    LOG
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      INTEGER   ITER
      REAL*8    T
      COMMON/evl___TERM/ITER,T(20)
      eval_term = 0.0 ! init
      ITER=ITER+1
      IF (ITER.GT.20) THEN
        REASON='TOO MUCH NESTING'
        ERR=POS
        RETURN
      ENDIF
      T(ITER)=SIGNEDFACTOR()
      IF (ERR.GT.0) RETURN
      DO WHILE (CH.EQ.'^')
        CALL eval_NEXTCH
        T(ITER)=EXP(LOG(T(ITER))*SIGNEDFACTOR())
        IF (ERR.GT.0) RETURN
      ENDDO
      eval_TERM=T(ITER)
      ITER=ITER-1
      RETURN
      END
      subroutine filescan(in,field,outfinal,lo)
      character in*(*)    !Input:  input filename
      character field*(*) !Input:
      character outfinal*(*)   !Output: result
      integer   lo        !Output: length of result
      integer   length
      character ufield*2  ! upcase first two chars of field
      integer   nodi      ! endposition of node
      integer   devi      ! endposition of device
      integer   rooi      ! endposition of root
      integer   diri      ! endposition of directory
      integer   nami      ! endposition of name
      integer   typi      ! endposition of type
      integer   veri      ! endposition of version
      integer   i
      character out*256
      out = ' '
      lo  = 0
      if(length(in).eq.0) goto 999
      nodi=index(in,'::')+1
      if (nodi.eq.1) nodi=0
      devi=nodi+index(in(nodi+1:),':')
      rooi=devi+index(in(devi+1:),'.]')
      if(rooi.gt.devi) rooi = rooi + 1
      diri=rooi+index(in(rooi+1:),']')
      veri=length(in)
      i=index(in(diri+1:),';')
      if (i.eq.0) then
        typi=veri
      else
        typi=diri+i-1
      endif
      i=index(in(diri+1:),'.')
      if (i.eq.0) then
        nami=typi
      else
        nami=diri+i-1
      endif
      call upcase(field(1:2),ufield)
      if(ufield.eq.'NO') then                    ! node
        lo = nodi
        if(lo.gt.0) out = in(1:nodi)
      else if(ufield.eq.'DE') then               ! device
        lo = devi - nodi
        if(lo.gt.0) out = in(nodi+1:devi)
      else if(ufield.eq.'RO') then               ! root
        lo = rooi-devi
        if(lo.gt.0) out = in(devi+1:rooi)
      else if(ufield.eq.'DI') then               ! directory
        lo = diri-rooi
        if(lo.gt.0) out = in(rooi+1:diri)
      else if(ufield.eq.'PA') then               ! path
        lo = diri
        if(lo.gt.0) out = in(1:diri)
      else if(ufield.eq.'NA') then               ! name
        lo = nami-diri
        if(lo.gt.0) out = in(diri+1:nami)
      else if(ufield.eq.'TY') then               ! type
        lo = typi-nami
        if(lo.gt.0) out = in(nami+1:typi)
      else if(ufield.eq.'FI') then               ! file
        lo = typi - diri
        if(lo.gt.0) out = in(diri+1:typi)
      else if(ufield.eq.'VE') then               ! version
        lo = veri-typi
        if(lo.gt.0) out = in(typi+1:veri)
      endif
999   outfinal = out
      return
      end
      subroutine finish(nunit)
      integer   nunit
      character datetime*20
      character cputime*12
      character image*80
      integer   li
      call image_name(image,li)
      if (nunit.le.0) then
        call settime()
        if (nunit.lt.0) write(-nunit,100) image(1:li),'start',datetime()
      else
        write(nunit,100) image(1:li),'ended',datetime(),cputime()
      endif
100   format(1x,a,x,a,' at ',2a,' CPU_time used')
      return
      end
      subroutine get_commandline
      integer   length
      integer   lib$get_foreign
      character line*256
      integer   status
      integer   lc
      status = lib$get_foreign(line,,lc)
      if(.not.status) call lib$signal(%val(status))
      if(length(line).gt.0) call put_inp(line(1:lc))
      return
      end
      subroutine get_common(string,ier)
      character string*(*)
      integer   ier
      integer*4 lib$get_common
      integer*4 status
      status = lib$get_common(string)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine get_default_directory(string,ier)
      character string*(*)
      integer   ier
      call set_default_directory('[]',string,ier)
      return
      end
      subroutine get_inp(d,nd,s,*)
      character d*(*)
      integer   nd
      character s*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   length
      integer   lenstr
      character today*11
      character rolex*10
      character cputime*12
      real      second
      character dd*256
      integer   ndd
      character file_type*3
      real*8    value
      character reason*80
      character local*256
      character local2*256
      logical   exist
      logical   iftest
      logical   expr
      integer   pid
      integer   eof
      integer   ldd
      integer   ier
      integer   lft
      integer   idd
      integer   LL
      integer   i
      integer   ls,ld
      integer   n
      integer   lr
      integer   ier2
      integer   n1,n2,n3,n4
      real      r
      integer   nn
      integer   nl
      if (first_time) call get_inp_init(-5)
10    continue
      call get_inp_internal(dd,ndd,s,*900)
      if(dd(1:1).eq.'@') then
        dd = dd(2:)
        ldd = lenstr(dd)
        inquire(file=dd(1:ldd),exist=exist)
        if(.not.exist) then
          call image_name(file_type,lft)
          file_type(3:3) = 'C'
          call build_file(dd(1:ldd),' ',file_type,dd,ldd)
          inquire(file=dd(1:ldd),exist=exist)
        endif
        if(exist) then
          call get_inp_stack(flag_push,ier)
          if(ier.ne.0) then
            if(nerr.gt.0) write (nerr,660)
660         format(' %GET_INP-W-STAOVE, input file stack overflow')
          else
            nrepeat = 0
            input_file_name = dd(1:ldd)
            call get_inp_open(dd(1:ldd),ninp,ier)
            if(ier.ne.0) then
              if (nerr.gt.0) then
                call get_message(ier,local,ier)
                write (nerr,670) local(1:lenstr(local))
              endif
              call get_inp_stack(flag_pop,ier)
            else
              call get_newline
              if(nlog.gt.0) write (nlog,662) ninp,dd(1:ldd)
662           format(' Opened ',i8,1x,a)
              if(echo_status.eq.echo_auto) nlog = nout
            endif
          endif
        else
          if(nerr.gt.0) write(nerr,663) dd(1:ldd)
663       format(' %GET_INP-W-FILNOTEXI, file ',a,' does not exist')
        endif
        goto 10
      else if(dd(1:max(1,lprefix)).eq.prefix.or.lprefix.eq.0) then
        dd = dd(lprefix+1:)
        ldd = lenstr(dd)
        call get_inp_find(dd,ldd,idd)   ! in upcase
        if(idd.lt.0) then
          d = dd
          nd = ndd
          return
        endif
 
        if(idd.eq.irepeat) then
          if(ndd.ge.2) then
            call get_inp_internal(dd,ndd,' ',*900)
            call get_integer(nrepeat,dd)
            if(nrepeat.le.0) then
              call get_newline
              nrepeat = 0
            else if(nrepeat.eq.1) then
              continue
              nrepeat = 0
            else
              nrepeat = nrepeat - 1
              call get_restline(repeat_line)
              istart = 1
              col = repeat_line
              repeat_modified = .false.
            endif
            goto 10
          endif
        else if(idd.eq.iprefix) then
          if(ndd.eq.0) then
            prefix = ' '
            lprefix = 0
          else
            call get_inp_internal(prefix,ndd,' ',*900)
            lprefix = length(prefix)
          endif
        else if(idd.eq.iecho) then
          call get_inp_internal(dd,ndd,'ON/OFF/AUTO/DEBUG',*900)
          if(echo_status.ne.echo_debug) then
            if(dd.eq.'ON') then
              nlog = nout
              echo_status = echo_on
            else if(dd.eq.'OFF') then
              nlog = 0
              echo_status = echo_off
            else if(dd.eq.'AUTO') then
              echo_status = echo_auto
            else if(dd.eq.'DEBUG') then
              nlog = nout
              echo_status = echo_debug
            endif
          endif
        else if(idd.eq.ijournal) then
          call get_inp_internal(dd,ndd,'ON/OFF/SUSPEND',*900)
          if(dd.eq.'ON') then
            if(.not.journalling.and.njournal.gt.0) then
              journalling = .true.    ! JOURNAL SUSPEND...JOURNAL ON
            else if(journalling) then ! JOURNAL ON ..... JOURNAL ON
              close(njournal)
              journalling = .false.
              njournal = 0
            endif
            if(njournal.eq.0) then
              call get_lun(njournal,ier)
              if(ier.ne.0) then
                if(nerr.gt.0) write (nerr,540)
540             format(' %GET_INP-W-TOOMANOPEN, too many open files')
              else
                call image_name(local,LL)
                local = local(1:LL)//'.JRN'
                ll = ll + 4
                open(unit=njournal,file=local(1:ll),status='new',
     1           carriagecontrol='list',iostat=ier)
                if(ier.ne.0) then
                  if(nerr.gt.0) write (nerr,542) local(1:LL)
542               format(' %GET_INP-W-CANNOTCRE, cannot create file ',a)
                else
                  journalling = .true.
                endif ! ier open
              endif ! ier get_lun
            endif ! njournal
          else if(dd.eq.'OFF') then
            if (njournal.gt.0) then
              close(njournal)
              journalling = .false.
              njournal=0
            endif
          else if(dd.eq.'SUSPEND') then
            journalling = .false.
          endif
        else if(idd.eq.iALIAS) then
          if(ndd.eq.0) then
            if(nout.gt.0) then
              do i=1,n_alias
                ls = lenstr(alias_source(i))
                ld = lenstr(alias_destination(i))
                if (ls+ld+3.gt.80) ld = 80-ls-3
                write (nout,600) alias_source(i)(1:ls),
     1           alias_destination(i)(1:ld)
600             format(1x,a,'=>',a)
              enddo
            endif
          else if(ndd.eq.1) then
            call get_inp_internal(dd,ndd,' ',*900)
            call get_inp_search_alias(dd,n)
            if(n.gt.0) then
              ls = lenstr(alias_source(n))
              ld = lenstr(alias_destination(n))
              if(nout.gt.0) write(nout,600) alias_source(n)(1:ls),
     1         alias_destination(n)(1:ld)
            else
              if(nerr.gt.0) write (nerr,620)
620           format(' %GET_INP-W-ALINOTFOU, alias not found')
            endif
          else
            call get_inp_internal(dd,ndd,' ',*900)
            call get_restline(local)
            call get_inp_add_alias(dd,local)
          endif
          call get_newline
          goto 10
        else if(idd.eq.iUNALIAS) then
          if(ndd.eq.0) then
            continue
          else
            call get_inp_internal(dd,ndd,' ',*900)
            if(dd.eq.'*') then
              n_alias = 0
            else
              call get_inp_search_alias(dd,n)
              if(n.eq.0) then
                if(nerr.gt.0) write(nerr,620)
              else
                alias_source(n) = alias_source(n_alias)
                alias_destination(n) = alias_destination(n_alias)
                n_alias = n_alias - 1
              endif
            endif
          endif
        else if(idd.eq.iEVALUATE) then
          call get_restline(local)
          call upcase(local,local)
          call str_collapse(local,local)
          call evaluate8(local,value,ier,reason)
          if(ier.eq.0) then
            if(nout.gt.0) write (nout,*) value
640         format(' result = ',g23.16)
            write (local,'(G23.16)') value
            call get_inp_add_alias('EVAL_RESULT',local)
          else
            if(nerr.gt.0) then
              write(nerr,645) local(1:lenstr(local))
645           format(1x,a/<ier>x,'^')
              lr = lenstr(reason)
              write (nerr,650) reason(1:lr)
650           format(' %EVALUATE-W-ERR, ',a)
            endif
          endif
          call get_newline
          goto 10
        else if(idd.eq.iSTORE) then
          call get_inp_internal(dd,nd,'Var name',*900)
          call get_inp_search_alias('EVAL_RESULT',n)
          if(n.gt.0) then
            call get_inp_add_alias(dd,alias_destination(n))
          else
            if(nerr.gt.0) write (nerr,670)
     1       ' %GET_INP-W-NOSTORE, nothing to store'
          endif
        else if(idd.eq.iHELP) then
          call get_restline(dd)
          call image_help(dd,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
          call get_newline
        else if(idd.eq.iHELPL) then
          call get_restline(dd)
          call help('lclrtl2_dir:get_inp.hlb',dd,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
          call get_newline
        else if(idd.eq.iHELPG) then
          call get_restline(dd)
          call help('graphics_dir:graphics.hlb',dd,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
          call get_newline
        else if(idd.eq.iDIRECTORY) then
          if (ndd.gt.0) then
            call get_inp_internal(local,ndd,' ',*900)
          else
            local = '*.*;*'
          endif
          ll = lenstr(local)
          call directory(0,local(1:LL),local2,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier2)
            write (nerr,670) local(1:lenstr(local))
          endif
          do while(ier.eq.0)
            if(nout.gt.0) write (nout,670) local2(1:lenstr(local2))
670         format(1x,a)
            call directory(1,local(1:LL),local2,ier)
          enddo
          call directory(-1,local(1:LL),local2,ier)
        else if(idd.eq.iEDIT) then
          call get_inp_internal(dd,ndd,'File name',*900)
          call editor(dd,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
        else if(idd.eq.iCD) then
          call get_inp_internal(dd,ndd,'Directory specification',*900)
          call set_default_directory(dd,previous_directory,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
          if(nout.gt.0) write (nout,674) previous_directory
     1     (1:lenstr(previous_directory))
674       format(' Previous directory=',a)
          if(nout.gt.0) then
            call get_default_directory(local,ier)
            if(ier.ne.0.and.nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            else
              write (nout,673) local(1:lenstr(local))
673           format(' Current directory=',a)
            endif
          endif
        else if(idd.eq.iBACK) then
          if(length(previous_directory).gt.0) then
            call set_default_directory(previous_directory,
     1       local,ier)
            if(ier.ne.0.and.nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            else
              previous_directory = local
            endif
          endif
          if(nout.gt.0) then
            call get_default_directory(local,ier)
            if(ier.ne.0.and.nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            endif
            write (nout,673) local(1:lenstr(local))
          endif
        else if(idd.eq.iIMPORT) then
          call get_inp_internal(dd,ndd,'Symbol name',*900)
          ldd = lenstr(dd)
          call get_symbol(dd(1:ldd),local)
          call get_inp_add_alias(dd(1:ldd),local)
        else if(idd.eq.iEXPORT) then
          call get_inp_internal(dd,ndd,'Alias name',*900)
          call get_inp_search_alias(dd,n)
          if(n.eq.0) then
            if(nerr.gt.0) write(nerr,620)
          else
            ll = lenstr(alias_destination(n))
            call set_symbol(dd(1:ldd),alias_destination(n)(1:LL))
          endif
        else if(idd.eq.iMKDIR) then
          call get_inp_internal(dd,ndd,'Directory specification',*900)
          call create_directory(dd,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
        else if(idd.eq.iGET_COMMON) then
          call get_common(local,ier)
          if(ier.eq.0) then
            if(nout.gt.0) write (nout,670) local(1:lenstr(local))
            call get_inp_add_alias('COMMON',local)
          else
            if(nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            endif
          endif
        else if(idd.eq.iDEFINE_KEY) then
          call get_inp_internal(dd,ndd,'Key name',*900)
          call get_restline(local)
          call get_newline
          call get_inp_add_key(dd,local,ktid,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
        else if(idd.eq.iSET_COMMON) then
          call get_restline(local)
          call set_common(local(1:lenstr(local)),ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
          call get_newline
        else if(idd.eq.iSET_FILES) then
          call get_inp_internal(dd,ndd,'Input unit',*900)
          call get_integer(n1,dd)
          call get_inp_internal(dd,ndd,'Output unit',*900)
          call get_integer(n2,dd)
          call get_inp_internal(dd,ndd,'Error unit',*900)
          call get_integer(n3,dd)
          call get_inp_internal(dd,ndd,'LOG unit',*900)
          call get_integer(n4,dd)
          call set_files(n1,n2,n3,n4)
        else if(idd.eq.iSPAWN) then
          if(ndd.eq.0.and.nerr.gt.0) then
            write(nerr,695)
695         format(' %GET_INP-W-NOCOMONL, no command on line')
          else
            call get_restline(local)
            call spawn_nowait(local,pid,ier)
            call get_newline
            if(ier.ne.0.and.nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            else
              write (local,'(Z8.8)') pid
              call get_inp_add_alias('PID',local(1:lenstr(local)))
              if(nout.gt.0) write(nout,691) pid
691           format(' Created process ',z8.8)
            endif
          endif
        else if(idd.eq.iSTATUS) then
          if(nout.gt.0) then
            call image_name(local,LL)
            write (nout,300) local(1:LL),today(),rolex()
300         format(' Status of ',a,' at ',a,a)
            if(journalling) then
              write (nout,302) local(1:LL)
302           format(' Journalling to file ',a,'.JRN')
            else
              if(njournal.gt.0) write (nout,304) local(1:LL)
304           format(' Journalling to file ',a,'.JRN suspended')
            endif
            call get_default_directory(local,ier)
            write (nout,306) local(1:lenstr(local))
306         format(' Current directory =',a)
            inquire(unit=nout,name=local)
            write (nout,308) 'Output',nout,local(1:lenstr(local))
308         format(1x,a,'file = ',i3,1x,a)
            if(nerr.gt.0) then
              inquire(unit=nerr,name=local)
            else
              local = 'Not in use'
            endif
            write (nout,308) ' Error',nerr,local(1:lenstr(local))
            if(nlog.gt.0) then
              inquire(unit=nlog,name=local)
            else
              local = 'Not in use'
            endif
            write (nout,308) '   Log',nlog,local(1:lenstr(local))
            call get_inp_stack(flag_status,ier)
            do i=1,putbuffer_pointer
              ll = lenstr(putbuffer(i))
              write (nout,310) i,putbuffer(i)(1:LL)
310           format(' putbuf.:',i4,':',a)
            enddo
            write (nout,312) word_count , line_count
312         format(' Word count = ',i8,' Line count = ',i8)
          endif
        else if(idd.eq.iATTACH) then
          call get_inp_search_alias('PID',n)
          if(n.gt.0) then
            read(alias_destination(n),'(Z8.8)') pid
            if(nout.gt.0) write(nout,692) pid
692         format(' Attaching to process ',z8.8)
            call attach(pid,ier)
            if(ier.ne.0.and.nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            endif
          else
            if(nerr.gt.0) write (nerr,693)
693         format(' %GET_INP-W-SUBPIDNOTFOU, subprocess pid not found')
          endif
        else if(idd.eq.iVMS) then
          if(nout.gt.0) write (nout,681)
681       format(' Creating VMS process. Type LOGOUT to ',
     1     'return to program')
          call vms_shell(pid,ier)
          if(ier.ne.0) then
            if(nerr.gt.0) then
              call get_message(ier,local,ier)
              write (nerr,670) local(1:lenstr(local))
            endif
          else
            write (local,'(Z8.8)') pid
            call get_inp_add_alias('PID',local(1:lenstr(local)))
            if(nout.gt.0) write(nout,691) pid
            call set_symbol('PID',local(1:lenstr(local)))
          endif
        else if(idd.eq.iRENAME) then
          call get_inp_internal(local,ndd,'Old file name',*900)
          call get_inp_internal(local2,ndd,'New file name',*900)
          call rename_file(local,local2,ier)
          if(ier.ne.0.and.nerr.gt.0) then
            call get_message(ier,local,ier)
            write (nerr,670) local(1:lenstr(local))
          endif
        else if(idd.eq.iTIME) then
          if(nout.gt.0) write (nout,670) rolex()
        else if(idd.eq.iDATE) then
          if(nout.gt.0) write (nout,670) today()
        else if(idd.eq.iSETCPU) then
          call settime
        else if(idd.eq.iCPU) then
          if(nout.gt.0) write (nout,670) cputime()
        else if(idd.eq.iSECOND) then
          if(nout.gt.0) write (nout,677) second()
677       format(1x,f13.2)
        else if(idd.eq.iSETEOF) then
          call get_inp_seteof
        else if(idd.eq.iWAIT) then
          call get_inp_internal(local,ndd,'nr of seconds',*900)
          call get_real(r,local)
          if(r.ge.0.0) then
            call str_real_len(1)
            if(nout.gt.0) call str_real_write(nout,r,
     1       'Waiting # seconds')
            call mywait(r)
            call str_real_len(-1)
          endif
        else if(idd.eq.iPAUSE) then
          call get_mode(local)
          if(local(1:1).eq.'I') then
            call get_inp_stack(flag_push,ier)
            nrepeat = 0
            input_file_name = 'sys$input'
            call get_inp_open('sys$input',ninp,ier)
            if(ier.ne.0) then
              if (nerr.gt.0) then
                call get_message(ier,local,ier)
                write (nerr,670) local(1:lenstr(local))
              endif
              call get_inp_stack(flag_pop,ier)
            else
              call get_newline
              if(nlog.gt.0) write (nlog,'(1x)')
              nn = putbuffer_pointer
              putbuffer_pointer = 0
              empty_lines_allowed = .true.
              call get_inp_internal(local,nl,'Type RETURN to continue',
     1         *354)
354           putbuffer_pointer = nn
              empty_lines_allowed = .false.
              call get_inp_stack(flag_pop,ier)
            endif
          endif
        else if(idd.eq.iWL) then
          if(nout.gt.0) write (nout,670) char(27)//'[?3h'
        else if(idd.eq.iWN) then
          if(nout.gt.0) write (nout,670) char(27)//'[?3l'
        else if(idd.eq.iIF) then
          call get_inp_internal(local,ndd,'expression',*900)
          if(local.eq.'NOT') then
            expr = .false.
            call get_inp_internal(local,ndd,'expression',*900)
          else
            expr = .true.
          endif
          if(local.eq.'FILE') then
            call get_inp_internal(local2,ndd,'filename',*900)
            ll = lenstr(local2)
            inquire(file=local2(1:ll),exist=iftest)
            if(.not.(iftest.eq.expr)) call get_newline
          else if(local.eq.'EQS') then
            call get_inp_internal(local,ndd,'string1',*900)
            call get_inp_internal(local2,ndd,'string2',*900)
            iftest = (local.eq.local2)
            if(.not.(iftest.eq.expr)) call get_newline
          else
            if(nerr.gt.0) write (nerr,679) local(1:ll)
679         format('%GET_INP-W-UNKEXP, Unknown expression:',a)
          endif
        else if(idd.eq.iCLS) then
          if(nout.gt.0) write (nout,670)
     1     char(27)//'[2J'//char(27)//'[0;0H'
        else if(idd.eq.iBELL) then
          if(nout.gt.0) write (nout,680) char(7)
680       format('+',a)
        else if(idd.eq.iSETPL) then
        else if(idd.eq.iSETPLR) then
        else if(idd.eq.iLISTPL) then
        else if(idd.eq.iOPTPL) then
        else if(idd.eq.iGETPL) then
        else if(idd.eq.iGETPLR) then
        else
          return  ! prefixed unknown command, can never be true
        endif
        repeat_modified = .true.
        call get_restline(col)
        istart = 1
        goto 10
      endif
      d = dd
      nd = ndd
      return
900   continue
      call get_inp_close(eof)
      if(eof.ne.0) goto 10  ! ignore this end of file
      return 1
      end
      subroutine get_inp_add_alias(source,destination)
      character source*(*)
      character destination*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   n
      if(n_alias.eq.max_alias) then
        if(nerr.gt.0) write (nerr,610) max_alias
610     format(' %GET_INP-W-MAXALIEXC, maximum aliases (',i3,
     1   ') exceeded')
      else
        call get_inp_search_alias(source,n)
        if(n.eq.0) then
          n_alias = n_alias + 1
          n = n_alias
        endif
        alias_source(n) = source
        alias_destination(n) = destination
      endif
      return
      end
      subroutine get_inp_add_key(keyname,equiv,ktid,ier)
      character keyname*(*)
      character equiv*(*)
      integer   ktid
      integer   ier
      integer   smg$add_key_def
      integer   lenstr
      integer   status
      integer   attributes
      attributes =  2   ! smg$m_key_terminate
      status = smg$add_key_def(ktid,keyname(1:lenstr(keyname)),
     1  ,attributes,equiv(1:lenstr(equiv)))
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine get_inp_close(eof)
      integer   eof
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   lenstr
      integer   ninp_old
      character local*256
      logical   local_eof
      integer   ier
      ninp_old = ninp
      local = input_file_name
      local_eof = noweof
      call get_inp_stack(flag_pop,ier)
      if(ier.eq.0) then
        call get_inp_close_internal(ninp_old)
        if(echo_status.eq.echo_auto) nlog = 0
        if(nlog.gt.0) write (nlog,664) ninp_old,local(1:lenstr(local))
664     format(' Closed ',i8,1x,a)
        if(local_eof) then
          eof = 0   ! succes
        else
          eof = 1   ! ignore this end of file
        endif
      else
        eof = 0     ! succes
      endif
      return
      end
      subroutine get_inp_close_internal(unit)
      integer unit
      integer smg$delete_virtual_keyboard
      integer local_unit
      integer status
      local_unit = unit
      status = smg$delete_virtual_keyboard(local_unit)
      if(.not.status) call lib$signal(%val(status))
      return
      end
      subroutine get_inp_default(d,nd,s,*)
      character d*(*)
      integer   nd
      character s*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   length
      integer   indexL
      integer   i1,i2
      if (first_time) call get_inp_init(-5)
      empty_lines_allowed = .true.
      call get_inp(d,nd,s,*900)
      empty_lines_allowed = .false.
      if(d.eq.'*'.or.d.eq.'.') d = ' '
      if(length(d).eq.0) then
        i1 = index(s,'[')
        if(i1.gt.0) then
          i1 = i1 + 1
          i2 = index(s,']') ! is there a ]
          if(i2.ne.0) then
            i2 = indexL(s,']') ! yes, get last one
            i2 = i2 - 1
            if(i2.ge.i1) d = s(i1:i2)
          endif
        endif
      endif
      return
900   continue
      empty_lines_allowed = .false.
      return 1
      end
      subroutine get_inp_find(dd,ldd,idd)
      character dd*(*)
      integer ldd
      integer idd
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   max_test
      parameter (max_test=11)
      character test(ntest)*(max_test)
      integer   ltest(ntest)
      save test,ltest
      data test(iALIAS) /'ALIAS'/ ltest(iALIAS) / 5/
      data test(iATTACH) /'ATTACH'/ ltest(iATTACH) / 6/
      data test(iBACK) /'BACK'/ ltest(iBACK) / 4/
      data test(iBELL) /'BELL'/ ltest(iBELL) / 4/
      data test(iCD) /'CD'/ ltest(iCD) / 2/
      data test(iCLS) /'CLS'/ ltest(iCLS) / 3/
      data test(iCPU) /'CPU'/ ltest(iCPU) / 3/
      data test(iDATE) /'DATE'/ ltest(iDATE) / 4/
      data test(iDEFINE_KEY) /'DEFINE_KEY'/ ltest(iDEFINE_KEY) /10/
      data test(iDIRECTORY) /'DIRECTORY'/ ltest(iDIRECTORY) / 9/
      data test(iECHO) /'ECHO'/ ltest(iECHO) / 4/
      data test(iEDIT) /'EDIT'/ ltest(iEDIT) / 4/
      data test(iEVALUATE) /'EVALUATE'/ ltest(iEVALUATE) / 8/
      data test(iEXPORT) /'EXPORT'/ ltest(iEXPORT) / 6/
      data test(iGETPL) /'GETPL'/ ltest(iGETPL) / 5/
      data test(iGETPLR) /'GETPLR'/ ltest(iGETPLR) / 6/
      data test(iGET_COMMON) /'GET_COMMON'/ ltest(iGET_COMMON) /10/
      data test(iHELP) /'HELP'/ ltest(iHELP) / 4/
      data test(iHELPG) /'HELPG'/ ltest(iHELPG) / 5/
      data test(iHELPL) /'HELPL'/ ltest(iHELPL) / 5/
      data test(iIF) /'IF'/ ltest(iIF) / 2/
      data test(iIMPORT) /'IMPORT'/ ltest(iIMPORT) / 6/
      data test(iJOURNAL) /'JOURNAL'/ ltest(iJOURNAL) / 7/
      data test(iLISTPL) /'LISTPL'/ ltest(iLISTPL) / 6/
      data test(iMKDIR) /'MKDIR'/ ltest(iMKDIR) / 5/
      data test(iOPTPL) /'OPTPL'/ ltest(iOPTPL) /5/
      data test(iPAUSE) /'PAUSE'/ ltest(iPAUSE) / 5/
      data test(iPREFIX) /'PREFIX'/ ltest(iPREFIX) / 6/
      data test(iRENAME) /'RENAME'/ ltest(iRENAME) / 6/
      data test(iREPEAT) /'REPEAT'/ ltest(iREPEAT) / 6/
      data test(iSECOND) /'SECOND'/ ltest(iSECOND) / 6/
      data test(iSETCPU) /'SETCPU'/ ltest(iSETCPU) / 6/
      data test(iSETPL) /'SETPL'/ ltest(iSETPL) / 5/
      data test(iSETPLR) /'SETPLR'/ ltest(iSETPLR) / 6/
      data test(iSET_COMMON) /'SET_COMMON'/ ltest(iSET_COMMON) /10/
      data test(iSETEOF) /'SETEOF'/ ltest(iSETEOF) /6/
      data test(iSET_FILES) /'SET_FILES'/ ltest(iSET_FILES) / 9/
      data test(iSPAWN) /'SPAWN'/ ltest(iSPAWN) / 5/
      data test(iSTATUS) /'STATUS'/ ltest(iSTATUS) / 6/
      data test(iSTORE) /'STORE'/ ltest(iSTORE) / 5/
      data test(iTIME) /'TIME'/ ltest(iTIME) / 4/
      data test(iUNALIAS) /'UNALIAS'/ ltest(iUNALIAS) / 7/
      data test(iVMS) /'VMS'/ ltest(iVMS) / 3/
      data test(iWAIT) /'WAIT'/ ltest(iWAIT) / 4/
      data test(iWL) /'WL'/ ltest(iWL) / 2/
      data test(iWN) /'WN'/ ltest(iWN) / 2/
      integer nmatch
      integer i
      nmatch=0
      idd=-1
      if(ldd.gt.max_test) return
      do i=1,ntest
        if (dd(1:ldd).eq.test(i)(1:ldd)) then
          idd=i
          if(ldd.eq.ltest(i)) return
          nmatch=nmatch+1
        endif
      enddo
      if (nmatch.gt.1) idd=-1
      return
      end
      subroutine get_inp_init(flag)
      integer   flag
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   smg$create_key_table
      integer   lenstr
      integer   status
      character local*256
      character init_file_name*256
      character get_nodename*15
      integer   LL
      integer   li
      integer   ier
      data first_time /.true./
      first_time = .false.
      if(flag.ne.0) ninp = -5
      nout = 6
      nerr = 6
      nlog = 0
      seteof = .false.
      noweof = .false.
      do_upcase = .true.
      empty_lines_allowed = .false.
      init_busy = 0
      echo_status = echo_init
      status = smg$create_key_table(ktid)
      if(.not.status) call lib$signal(%val(status))
      prefix = '\'
      lprefix = 1
      prompt = ' '
      lp = 2
      n_alias = 0
      journalling = .false.
      njournal = 0
      col = ' '
      istart = 1
      nrepeat = 0
      repeat_line = ' '
      if(flag.ne.0) input_file_name = 'Unknown?'
      call image_path(local,LL)
      call get_inp_add_alias('IMAGE_PATH',local(1:LL))
      init_file_name = local(1:LL)
      li = LL
      call image_name(local,LL)
      call get_inp_add_alias('IMAGE_NAME',local(1:LL))
      init_file_name = init_file_name(1:li)//local(1:ll)//
     1 '.init'
      call get_username(local)
      call get_inp_add_alias('USER_NAME',local(1:lenstr(local)))
      call get_default_directory(local,ier)
      if(ier.eq.0) call get_inp_add_alias('WORK_DIR',
     1  local(1:lenstr(local)))
      call get_inp_add_alias('NODE_NAME',get_nodename())
      call get_mode(local)
      call get_inp_add_alias('PROCESS_MODE',local(1:lenstr(local)))
      call get_processname(local)
      call get_inp_add_alias('PROCESS_NAME',local(1:lenstr(local)))
      call get_inp_stack(flag_push,ier)
      input_file_name = 'GET_INP$INIT'
      call get_inp_open(input_file_name,ninp,ier)
      if(ier.ne.0) then
        call get_inp_stack(flag_pop,ier)
      else
        init_busy = ninp
        call get_newline
      endif
      call get_inp_stack(flag_push,ier)
      input_file_name = init_file_name
      call get_inp_open(input_file_name,ninp,ier)
      if(ier.ne.0) then
        call get_inp_stack(flag_pop,ier)
      else
        if(init_busy.eq.0) init_busy = ninp
        call get_newline
      endif
      word_count = 0
      line_count = 0
      putbuffer_pointer = 0
      return
      end
      SUBROUTINE get_inp_internal(dd,ndd,s, *)
      character dd*(*)
      integer   ndd
      character s*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      include '($smgdef)'
      include '($smgmsg)'
      integer   lib$get_input
      integer   smg$read_composed_line
      integer   length
      integer   status
      character c*1
      logical   substitute_flag
      integer   status_eof
      integer   ier
      integer   i1,i2,i3
      integer   lc
      integer   ls
      integer   ldd
      integer   idd
 
      status_eof = smg$_eof
      if(status_eof.eq.0) then
        status_eof = '00128402'X
      endif
 
      word_count  = word_count  + 1
 
      if(ninp.lt.0) then
        input_file_name = 'sys$input'
        call get_inp_open(input_file_name,ninp,ier)
        call get_newline
        if(nout.gt.0) write (nout,'(1x)')
      endif
 
10    call get_inp_one_par(istart,i2)
      if(i2.gt.istart) then
        if(do_upcase) then
          call Upcase(col(istart:i2),dd)
        else
          dd = col(istart:i2)
        endif
        istart = i2+1
        nitem = nitem - 1
        ndd = nitem
        RETURN
      endif
30    continue
      if(nrepeat.gt.0) then
        nrepeat = nrepeat - 1
        if(repeat_modified) col = repeat_line
        lc = length(col)
      else if(putbuffer_pointer.gt.0.and.init_busy.eq.0) then
        col = putbuffer(putbuffer_pointer)
        putbuffer_pointer = putbuffer_pointer - 1
        lc = length(col)
      else
        if(ninp.eq.0) goto 70  ! eof if no input file specified
        line_count = line_count + 1
        ls = length(s)
        if(ls.eq.0) then
          if(prompt.eq.' ') then
             call image_name(prompt,lp)
             c = prompt(1:1)
             call lowercase(prompt(2:),prompt)
             prompt = c//prompt(1:lp-1)//'>'
             lp = lp + 1
          endif
          status = smg$read_composed_line(ninp,ktid,col,prompt(1:lp),lc)
        else
          status = smg$read_composed_line(ninp,ktid,col,s(1:ls)//':',lc)
        endif ! ls
        if(.not.status) then
          if (status.eq.status_eof) then
            goto 70
          else
            call lib$signal(%val(status))
          endif
        endif
        if(journalling) then
          if(col(1:1).eq.'@') then
            write (njournal,605) col(1:max(1,lc))
605         format('!',a)
          else
            write (njournal,606) col(1:max(1,lc))
606         format(a)
          endif
        endif
      endif ! repeat
      if(nlog.ne.0)  write(nlog,610) col(1:max(1,lc))
610   format(1x,a)
      if(lc.eq.0.and.empty_lines_allowed) then
        dd = ' '
        ndd = 0
        nitem = 0
        call get_newline
        return
      endif
 
      if(lc.eq.0) goto 30
      if(col(1:1).eq.'!') goto 30
 
      istart = 1
        do while(col(istart:istart).eq.' ')
          istart = istart + 1
        enddo
        if(istart.gt.1) then
          col = col(istart:)
          istart = 1
        endif
        i1 = istart
        call get_inp_one_par(i1,i2)
        i2 = i2 - 1
        if(i2.ge.i1) then
          substitute_flag=.true.
          call get_inp_substitute(i1,i2,substitute_flag)
          call get_inp_one_par(i1,i3)
          i3 = i3 - 1
          call upcase(col(i1:i3),dd)
          if((dd(1:max(1,lprefix)).eq.prefix).or.(lprefix.eq.0)) then
            ldd = i3-i1+1-lprefix
            call get_inp_find(dd(lprefix+1:),ldd,idd)    !  dd in upcase
            if(idd.eq.ialias.or.idd.eq.iunalias.or.
     1         idd.eq.istore.or.idd.eq.iexport.or.idd.eq.iimport)
     2       substitute_flag=.false.
          endif
          i1 = i2 + 1
          call get_inp_one_par(i1,i2)
          i2 = i2 - 1
          do while(i2.ge.i1)
            call get_inp_substitute(i1,i2,substitute_flag)
            i1 = i2 + 1
            call get_inp_one_par(i1,i2)
            i2 = i2 - 1
          enddo
        endif
      NITEM = 0
      i1 = istart
      call get_inp_one_par(i1,i2)
      do while(i2.gt.i1)
        nitem = nitem + 1
        i1 = i2
        call get_inp_one_par(i1,i2)
      enddo
      goto 10
70    continue
      if(init_busy.eq.ninp) then
        init_busy = 0
        if(echo_status.eq.echo_init) echo_status = echo_auto
      endif
      RETURN 1
      END
      subroutine get_inp_one_par(i1,i2)
      integer i1,i2
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      if(i1.ge.len(col)) then
        i2 = i1
        return
      endif
      do while((col(i1:i1).eq.' '.or.col(i1:i1).eq.',').and.
     1         i1.lt.len(col))
        i1 = i1 + 1
      enddo
      i2 = i1
      if(i1.eq.len(col)) return
      do while(col(i2:i2).ne.' '.and.col(i2:i2).ne.','.and.
     1         i2.lt.len(col))
        i2 = i2 + 1
      enddo
      return
      end
      subroutine get_inp_open(name,unit,ier)
      character name*(*)
      integer   unit
      integer   ier
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   smg$create_virtual_keyboard
      integer   lenstr
      integer   status
      integer   local_unit
      integer   ln
      ln = lenstr(name)
      local_unit = unit
      status = smg$create_virtual_keyboard(unit,name(1:ln))
      if(.not.status) then
        ier = status
      else
        if(init_busy.eq.0.and.local_unit.gt.0) noweof=seteof
        ier = 0
      endif
      if(init_busy.eq.0.and.local_unit.gt.0) seteof=.false.
      return
      end
      subroutine get_inp_search_alias(string,n)
      character string*(*)
      integer   n
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   i
      do i=1,n_alias
        if(string.eq.alias_source(i)) then
          n = i
          return
        endif
      enddo
      n = 0
      return
      end
      subroutine get_inp_seteof
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      if (first_time) call get_inp_init(-5)
      seteof = .true.
      return
      end
      subroutine get_inp_stack(flag,ier)
      integer   flag
      integer   ier
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   lenstr
      integer   max_stack
      parameter (max_stack=20)
      integer   sp
      integer   file_stack(max_stack)
      character col_stack(max_stack)*256
      integer   istart_stack(max_stack)
      character repeat_line_stack(max_stack)*256
      integer   nrepeat_stack(max_stack)
      character file_name_stack(max_stack)*256
      logical   eof_stack(max_stack)
      save sp,file_stack,col_stack,istart_stack,repeat_line_stack,
     1 nrepeat_stack,file_name_stack,eof_stack
      data sp /0/
      integer   i,j
      integer   LL
      if(flag.eq.flag_push) then
        if(sp.ge.max_stack) then
          ier = 1
          return
        endif
        sp = sp + 1
        eof_stack(sp)          = noweof
        file_stack(sp)         = ninp
        col_stack(sp)          = col
        istart_stack(sp)       = istart
        nrepeat_stack(sp)      = nrepeat
        repeat_line_stack(sp)  = repeat_line
        file_name_stack(sp)    = input_file_name
      else if(flag.eq.flag_pop) then
        if(sp.le.0) then
          ier = 1
          return
        endif
        noweof      = eof_stack(sp)
        ninp        = file_stack(sp)
        col         = col_stack(sp)
        istart      = istart_stack(sp)
        nrepeat     = nrepeat_stack(sp)
        repeat_line = repeat_line_stack(sp)
        input_file_name = file_name_stack(sp)
        sp = sp - 1
      else if(flag.eq.flag_status) then
        do i=1,sp
          LL = lenstr(file_name_stack(i))
          write (nout,605) i,file_stack(i),file_name_stack(i)(1:LL),
     1     eof_stack(i)
605       format(' file   :nr=',i2,i8,' : ',a,'  eof-flag=',L1)
          if(istart_stack(i).eq.len(col)+1) then
            write(nout,607)
607         format(' Positioned at beginning of file')
          else
            LL = lenstr(col_stack(i))
            write (nout,600) col_stack(i)(1:LL)
600         format(' command:',a)
            j = istart_stack(i) - 1
            write (nout,610)
610         format(' pointer:',<j>x,'^')
          endif
          if(nrepeat_stack(i).gt.0) then
            ll = lenstr(repeat_line_stack(i))
            write(nout,620) nrepeat_stack(i),
     1       repeat_line_stack(i)(1:LL)
620         format('  repeat:',i4,':',a)
          endif
        enddo
        LL = lenstr(input_file_name)
        write (nout,605) 0,ninp,input_file_name(1:LL),noweof
        LL = lenstr(col)
        write (nout,600) col(1:LL)
        j = istart - 1
        write (nout,610)
        if(nrepeat.gt.0) then
          ll = lenstr(repeat_line)
          write(nout,620) nrepeat,repeat_line(1:LL)
        endif
        write (nout,630) seteof
630     format(' EOF flag for next @file = ',L1)
      endif
      ier = 0
      return
      end
      subroutine get_inp_substitute(i1,i2,dowhole)
      integer   i1
      integer   i2
      logical   dowhole
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer   lenstr
      integer   n1
      integer   n2
      character word*256
      character word2*256
      integer   lw
      integer   n
      integer   ln
 
      word = col(i1:i2)
      lw = i2-i1+1
      n1 = index(word,'''')
      if(n1.eq.0) then
        if(dowhole) then
          call upcase(word,word2)
          call get_inp_search_alias(word2,n)
          if(n.gt.0) then
            ln = lenstr(alias_destination(n))
            word = alias_destination(n)(1:ln)
            lw = ln
          endif ! n > 0
        endif
      else
        do while(n1.gt.0)
          n2 = index(word(n1+1:),'''')
          if(n2.eq.0) then
            if(n1.gt.1) then
              word = word(1:n1-1)//word(n1+1:)   ! ab'cd
            else
              word = word(2:)                    ! 'ab
            endif
            lw = lw - 1
            n2 = lw
          else if(n2.eq.1) then
            if(n1.gt.1) then
              word = word(1:n1)//word(n1+2:)     ! ab''cd
            else
              word = word(2:)                    ! ''abc
            endif
            lw = lw - 1
            n2 = n1
            n1 = n2 + 1     ! disable substitution
          else ! n2 > 1
            n2 = n1 + n2
            if(n1.gt.1) then
              word = word(1:n1-1)//word(n1+1:n2-1)//word(n2+1:) ! ab'c'd
            else
              word = word(2:n2-1)//word(n2+1:)                  ! 'cd'e
            endif
            lw = lw - 2
            n2 = n2 - 2
          endif ! n2
          if(n1.le.n2) then
            call upcase(word(n1:n2),word2(n1:n2))
            call get_inp_search_alias(word2(n1:n2),n)
            if(n.gt.0) then
              ln = lenstr(alias_destination(n))
              if(n1.gt.1) then
                word = word(1:n1-1)//alias_destination(n)(1:ln)//
     1           word(n2+1:)
              else
                word = alias_destination(n)(1:ln)//word(n2+1:)
              endif
              lw = lw - (n2-n1+1) + ln
              n2 = n1 + ln - 1
            endif ! n > 0
          endif ! n1 < n2
          n1 = index(word(n2+1:),'''')
          if (n1.gt.0) n1 = n1 + n2
        enddo
      endif
        if(i1.gt.1) then
          col = col(1:i1-1)//word(1:lw)//col(i2+1:)
        else
          col = word(1:lw)//col(i2+1:)
        endif
        i2 = i1 + lw - 1
      return
      end
      subroutine get_integer(ix,dd)
      integer   ix
      character dd*(*)
      real      r
      call get_real(r,dd)
      ix = nint(r)
      return
      end
      subroutine get_logical(s1,s2)
      character s1*(*)
      character s2*(*)
      integer*4 lib$sys_trnlog
      integer   lenstr
      character s3*255
      integer*4 status
      call upcase(s1,s3)
      status = lib$sys_trnlog(S3(1:lenstr(s3)),,s2)
      if (.not.status) call lib$signal(%val(status))
      return
      end
      subroutine get_lun(unit,ier)
      integer unit                        ! returned unit number
      integer ier                         ! 0=ok, <>0 = no free unit available
      integer max_lun
      parameter (max_lun=99)
      integer i
      logical opened
      do i=max_lun,1,-1
        inquire(unit=i,opened=opened)
        if(.not.opened) then
          unit = i
          ier  = 0
          return
        endif
      enddo
      ier = 1
      unit = 0
      return
      end
      subroutine get_message(nr,string,ier)
      integer*4 nr
      character string*(*)
      integer   ier
      integer*4 lib$sys_getmsg
      integer*4 status
      status = lib$sys_getmsg(nr,,string)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine get_mode(c)
      character c*(*)
      integer*4 lib$getjpi
      character modestring*11
      integer   status
      integer   code
      integer   pid
      integer   L
      integer   mode
      include '($jpidef)'
      code = jpi$_mode
      status = lib$getjpi(code,pid,,mode,modestring,l)
      if (.not.status) call lib$signal(%val(status))
      c = modestring
      return
      end
      subroutine get_newline
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      if (first_time) call get_inp_init(-5)
      ISTART = len(col) + 1
      RETURN
      end
      character*15 function get_nodename
      include '($syidef)'
      integer*4 sys$getsyi
      integer*4 item_list(4)
      integer*4 status
      integer   ln
      character node_name*15
      item_list(1) = syi$_nodename*2**16 + 15
      item_list(2) = %loc(node_name)
      item_list(3) = %loc(ln)
      item_list(4) = 0
      status = sys$getsyi(,,,item_list,,,)
      if (.not.status) then
         node_name='ErrErrErrErrErr'
         ln = 15
      endif
      get_nodename = node_name(1:ln)
      end
      subroutine get_processname(value)
      character value*(*)
      include '($jpidef)/nolist'
      integer*4 lib$getjpi
      integer*4 status
      integer*4 len
      status = lib$getjpi(jpi$_prcnam,,,,value,len)
      if (.not.status) then
        value='unknown'
      else
        if (len.eq.0) then
          value=' '
        else
          value=value(1:len)
        endif
      endif
      return
      end
      subroutine get_real(x,dd)
      real      x
      character dd*(*)
      integer   iostat
      read(dd,*,iostat=iostat) x
      if (iostat.ne.0) x = 0.0
      return
      end
      subroutine get_restline(l)
      character l*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      if (first_time) call get_inp_init(-5)
      if(istart.lt.len(col)) then
        l = col(istart:)
      else
        l = ' '
      endif
      return
      end
      subroutine get_symbol(symbol,value)
      character symbol*(*)
      character value*(*)
      integer*4 lib$get_symbol
      integer*4 status
      include '($libdef)'
      status = lib$get_symbol(symbol,value)
      if(.not.status) then
        value = ' '
      endif
      return
      end
      subroutine get_term_size(x,y)
      integer x
      integer y
      include '($DVIDEF)/nolist'
      integer*4 lib$getdvi
      integer   status
      status = lib$getdvi(DVI$_TT_PAGE,,'TT',y,,)
      if (.not.status) call lib$signal(%val(status))
      status = lib$getdvi(DVI$_DEVBUFSIZ,,'TT',x,,)
      if (.not.status) call lib$signal(%val(status))
      return
      end
      subroutine get_username(name)
      character name*(*)
      include '($jpidef)'
      integer*4 lib$getjpi
      integer*4 status
      integer   code
      integer   pid
      integer   l
      code = jpi$_username
      status = lib$getjpi(code,pid,,,name,l)
      if (.not.status) call lib$signal(%val(status))
      return
      end
      subroutine get___cputime(flag,value)
      integer flag
      integer value
      include '($jpidef)/nolist'
      integer lib$getjpi
      integer status
      integer msec
      save msec
      data msec /0/
      status = lib$getjpi(jpi$_cputim,,,value,,)
      if (.not.status) value=0
      if(flag.eq.1) then
        value = value - msec
      else
        msec = value
      endif
      return
      end
      subroutine help(library,key,ier)
      character library*(*)
      character key*(*)
      integer   ier
      include '($hlpdef)'
      integer*4 lbr$output_help
      integer*4 lib$get_input
      integer*4 lib$put_output
      external  lib$get_input
      external  lib$put_output
      integer   length
      character lib*80
      integer   flags
      integer   status
      integer   LL
      integer   LK
      flags = hlp$m_process+hlp$M_group+hlp$m_system+hlp$m_prompt
      lib = library
      ll = length(lib)
      if(ll.eq.0) then
        lib = 'helplib'
        ll = 7
      endif
      lk = length(key)
      if(lk.eq.0) lk = 1
      status = lbr$output_help(lib$put_output,,
     2            key(1:lk),
     1            lib(1:ll),
     3            flags,
     4            lib$get_input)
      if (.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine image_file(name,ln)
      character name*(*)
      integer   ln
      include '($jpidef)'
      integer*4 sys$getjpiw
      integer   length
      character image*132
      integer*4 status
      structure /item/
        integer*2 buflen
        integer*2 item
        integer*4 bufaddr
        integer*4 ladr
        integer*4 terminator
      end structure
      record /item/ item_list
 
      item_list.buflen     = len(image)
      item_list.item       = jpi$_imagname
      item_list.bufaddr    = %loc(image)
      item_list.terminator = 0
      status = sys$getjpiw(,,,item_list,,,)
      if (.not.status) call lib$signal(%val(status))
      name = image
      ln = length(image)
      return
      end
      subroutine image_help(text,ier)
      character text*(*)
      integer   ier
      character name*132
      integer   lp
      character path*132
      integer   ln
      call image_path(path,lp)
      call image_name(name,ln)
      call help(path(1:lp)//name(1:ln),text,ier)
      return
      end
      subroutine image_name(name,ln)
      character name*(*)
      integer   ln
      character s*80
      integer   ls
      call image_file(s,ls)
      call filescan(s(1:ls),'NAME',name,ln)
      return
      end
      subroutine image_path(name,ln)
      character name*(*)
      integer   ln
      character s*80
      integer   ls
      call image_file(s,ls)
      call filescan(s(1:ls),'PATH',name,ln)
      return
      end
      integer function indexL(s,c)
      character s*(*)
      character c*(*)
      integer lenstr
      integer lc,ls
      integer i,n
      lc = len(c)
      ls = len(s)
      do i=ls,1,-1
        if(s(i:i+lc-1).eq.c(1:lc)) then
          n = i
          goto 20
        endif
      enddo
      n = ls
20    continue
      indexl = n
      return
      end
      integer*4 function length(str)
      character str*(*)
      integer   ic
      integer   i
      do i=len(str),1,-1
        ic = ichar(str(i:i))
        if(ic.ne.ichar(' ').and.ic.ne.0) then
          length = i
          return
        endif
      enddo
      length = 0
      return
      end
      integer function lenstr(s)
      character s*(*)
      integer   length
      lenstr = max(1,length(s))
      return
      end
      subroutine lowercase(string1,string2)
      implicit none
      character string1*(*)
      character string2*(*)
      integer   length
      character c*1
      integer   i
      integer   delta
      delta = ichar('a')-ichar('A')
      string2 = string1
      do 10 i=1,length(string2)
        c = string2(i:i)
        if(c.ge.'A'.and.c.le.'Z') then
          string2(i:i) = char( ichar(c)+delta)
        endif
10    continue
      return
      end
      subroutine mywait(delta)
      real delta
      call lib$wait(delta)
      return
      end
      subroutine open_file(filename,unit,message,error)
      character filename*(*)
      integer   unit
      character message*(*)
      integer   error
      integer   lenstr
      integer   lf
      call get_lun(unit,error)
      lf = lenstr(filename)
      if(error.ne.0) then
        message = 'No free unit in open_file '//filename(1:lf)
        return
      endif
      open(unit=unit,file=filename(1:lf),status='old',readonly,
     1 shared,iostat=error)
      if(error.ne.0) then
        call str_integer(error,'Error # opening '//filename(1:lf),
     1   message)
      else
        message = 'Opened '//filename(1:lf)
      endif
      return
      end
      subroutine put_inp(dd)
      character dd*(*)
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      if (first_time) call get_inp_init(-5)
      if(putbuffer_pointer.ge.max_putbuffer) then
        if(nerr.gt.0) write (nerr,600) max_putbuffer
600     format(' %GET_INP-W-PUTBUFOVE, put buffer overflow.',
     1   ' Maximum = ',i3)
        return
      endif
      putbuffer_pointer = putbuffer_pointer + 1
      putbuffer(putbuffer_pointer) = dd
      return
      end
      subroutine rename_file(file1,file2,ier)
      character file1*(*)
      character file2*(*)
      integer ier
      integer   lenstr
      integer   lib$rename_file
      integer   status
      integer   lf1
      integer   lf2
      lf1 = lenstr(file1)
      lf2 = lenstr(file2)
      status = lib$rename_file(file1(1:lf1),file2(1:lf2))
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      character*10 function rolex()
      character dt*20
      call lib$date_time(dt)
      rolex = dt(12:)
      return
      end
      subroutine Row2Vec(rown,m,v)
      integer rown
      real m(3,3)
      real v(3)
      integer i
      do i=1,3
        v(i) = m(rown,i)
      enddo
      return
      end
      character*12 function sec2time(t)
      real    t
      integer days
      integer minutes
      integer hours
      integer seconds
      integer n
      integer ioerr
      n = nint(t)
      seconds = mod(n,60)
      n = n/60
      minutes = mod(n,60)
      n = n/60
      hours = mod(n,24)
      days = n/24
      write(sec2time,100,iostat=ioerr) days,hours,minutes,seconds
100   format(i3.0,x,i2.2,':',i2.2,':',i2.2)
      return
      end
      real function second()
      integer cpu
      call get___cputime(1,cpu)
      second = 0.01 *(float(cpu)+0.5)
      return
      end
      subroutine settime
      integer cpu
      call get___cputime(2,cpu)
      return
      end
      subroutine set_common(string,ier)
      character string*(*)
      integer   ier
      integer*4 lib$put_common
      integer   lenstr
      integer*4 status
      integer   ls
      ls = lenstr(string)
      status = lib$put_common(string(1:ls))
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine set_default_directory(new,old,ier)
      character new*(*)
      character old*(*)
      integer ier
      integer   lenstr
      integer   sys$setddir
      integer   lib$find_file
      integer   lib$find_file_end
      character local1*80
      character local2*80
      character wild*4
      integer   status
      integer   context
      integer   mask
      integer   ln
      integer   LL
      integer   LL2
      local1 = new
      call str_substitute(new,'][;',';',local1)
      ln = lenstr(local1)
      status = sys$setddir(local1(1:ln),LL,old)
      old = old(1:LL)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      call get_logical('SYS$DISK',local2)
      ll2 = lenstr(local2)
      old = local2(1:ll2)//old(1:LL)
      if(ier.eq.0) then
        mask = ibset(0,1)
        context = 0
        if(local1(ln:ln).eq.']') then
          wild = '*.*'
        else
          wild = ':*.*'
        endif
        status = lib$find_file(local1(1:ln)//wild,local1,
     1   %ref(context),,,,%ref(mask))
        status = lib$find_file_end(%ref(context))
        call filescan(local1,'DEVICE',local1,LL)
        if(LL.ge.2) then
          call set_logical('SYS$DISK',local1(1:LL))
        endif
      endif
      return
      end
      subroutine set_files(n1,n2,n3,n4)
      integer n1,n2,n3,n4
      integer   max_alias
      parameter (max_alias=100)
      integer   max_putbuffer
      parameter (max_putbuffer=10)
      integer echo_init,echo_off,echo_on,echo_auto,echo_debug
      parameter (echo_init  =-1)
      parameter (echo_off   = 0)
      parameter (echo_on    = 1)
      parameter (echo_auto  = 2)
      parameter (echo_debug = 3)
      integer iALIAS,iATTACH,iBACK,iCD,iCLS,iCPU,iDATE
      parameter (iALIAS =  1)
      parameter (iATTACH =  2)
      parameter (iBACK =  3)
      parameter (iCD =  4)
      parameter (iCLS =  5)
      parameter (iCPU =  6)
      parameter (iDATE =  7)
      integer   iDEFINE_KEY,iDIRECTORY,iECHO,iEDIT,iEVALUATE,iEXPORT
      parameter (iDEFINE_KEY =  8)
      parameter (iDIRECTORY =  9)
      parameter (iECHO = 10)
      parameter (iEDIT = 11)
      parameter (iEVALUATE = 12)
      parameter (iEXPORT = 13)
      integer   iGETPL,iGETPLR,iGET_COMMON,iHELP,iHELPG,iHELPL,iIMPORT
      parameter (iGETPL = 14)
      parameter (iGETPLR = 15)
      parameter (iGET_COMMON = 16)
      parameter (iHELP = 17)
      parameter (iHELPG = 18)
      parameter (iHELPL = 19)
      parameter (iIMPORT = 20)
      integer iJOURNAL,iLISTPL,iMKDIR,iPREFIX,iRENAME,iREPEAT,iSECOND
      parameter (iJOURNAL = 21)
      parameter (iLISTPL = 22)
      parameter (iMKDIR = 23)
      parameter (iPREFIX = 24)
      parameter (iRENAME = 25)
      parameter (iREPEAT = 26)
      parameter (iSECOND = 27)
      integer iSETCPU,iSETPL,iSETPLR,iSET_COMMON,iSET_FILES,iSPAWN
      parameter (iSETCPU = 28)
      parameter (iSETPL = 29)
      parameter (iSETPLR = 30)
      parameter (iSET_COMMON = 31)
      parameter (iSET_FILES = 32)
      parameter (iSPAWN = 33)
      integer   iSTATUS,iSTORE,iTIME,iUNALIAS,iVMS,iWL,iWN
      parameter (iSTATUS = 34)
      parameter (iSTORE = 35)
      parameter (iTIME = 36)
      parameter (iUNALIAS = 37)
      parameter (iVMS = 38)
      parameter (iWL = 39)
      parameter (iWN = 40)
      integer   iIF,iOPTPL,iWAIT,iPAUSE,iSETEOF,iBELL
      parameter (iIF = 41)
      parameter (iOPTPL = 42)
      parameter (iWAIT=43)
      parameter (iPAUSE=44)
      parameter (iSETEOF=45)
      parameter (iBELL=46)
      integer   ntest
      parameter (ntest=46)
 
      integer flag_pop,flag_push,flag_status
      parameter (flag_pop = 1)
      parameter (flag_push = 2)
      parameter (flag_status = 3)
      character col*256
      integer   nitem
      character prompt*80
      integer   lp
      integer   istart
      integer   nrepeat
      character alias_source*80
      character alias_destination*80
      integer   n_alias
      character repeat_line*256
      logical   repeat_modified
      character previous_directory*256
      logical   journalling
      integer   njournal
      integer   ktid
      integer   word_count
      integer   line_count
      character prefix*10
      integer   lprefix
      character putbuffer(max_putbuffer)*256
      integer   putbuffer_pointer
      logical   first_time
      integer   ninp,nout,nerr,nlog
      character input_file_name*80
      LOGICAL   command_line
      integer   init_busy
      integer   echo_status
      logical   seteof,noweof
      logical   empty_lines_allowed
      logical   do_upcase
      COMMON /get_inp___commmon/ COL,nitem,prompt,lp,
     1 istart,nrepeat,ktid,journalling,njournal,first_time,
     2 n_alias,alias_source(max_alias),alias_destination(max_alias),
     3 repeat_line,repeat_modified,previous_directory,word_count,
     4 line_count,prefix,lprefix,putbuffer,putbuffer_pointer,
     5 ninp,nout,nerr,nlog,command_line,init_busy,echo_status,
     6 input_file_name,seteof,noweof,empty_lines_allowed,do_upcase
      integer length
      character string*80
      integer   ier
      if (n2.ge.0) nout = n2
      if (n3.ge.0) nerr = n3
      if (n4.ge.0) nlog = n4
      if (n1.gt.0) then
        if(ninp.gt.0) call get_inp_close_internal(ninp)
        inquire(unit=n1,name=string)
        close(n1)
        if(length(string).eq.0) then
          string = 'sys$input'
        endif
        input_file_name = string
        call get_inp_open(string,ninp,ier)
        call get_newline
      else if(n1.eq.0) then
        if(ninp.gt.0) call get_inp_close_internal(ninp)
        ninp = 0
      endif
      if (first_time) then
        if (n1.ge.0) then
          call get_inp_init(0)
        else
          call get_inp_init(-5)
        endif
      endif
      return
      end
      subroutine set_logical(s1,s2)
      character s1*(*)
      character s2*(*)
      integer*4 lib$set_logical
      integer   lenstr
      integer*4 status
      character s3*255
      integer   ls2
      integer   ls3
      call upcase(s1,s3)
      ls2 = lenstr(s2)
      ls3 = lenstr(s3)
      status = lib$set_logical(S3(1:lenstr(s3)),s2(1:lenstr(s2)))
      return
      end
      subroutine set_symbol(symbol,value)
      character symbol*(*)
      character value*(*)
      integer*4 lib$set_symbol
      integer   length
      integer   status
      character s*138
      character v*138
      call upcase(symbol,s)
      call upcase(value,v)
      status = lib$set_symbol(s(1:length(s)),v(1:length(v)),2) ! global
      if (.not.status) call lib$signal(%val(status))
      return
      end
      REAL*8 FUNCTION SIGNEDFACTOR
      REAL*8    eval_FACTOR
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      IF (CH.EQ.'-') THEN
        CALL eval_NEXTCH
        SIGNEDFACTOR=-eval_FACTOR()
        IF (ERR.GT.0) RETURN
      ELSE
        SIGNEDFACTOR=eval_FACTOR()
        IF (ERR.GT.0) RETURN
      ENDIF
      RETURN
      END
      REAL*8 FUNCTION SIMPLE_EXPRESSION
      REAL*8    eval_TERM
      CHARACTER FORM*255
      INTEGER   POS
      CHARACTER CH
      integer   ERR
      CHARACTER REASON*25
      integer   lf
      COMMON/evl___EVALUATE/FORM,POS,CH,ERR,REASON,lf
      INTEGER   ISIM
      CHARACTER OPS
      REAL*8    S
      real*8    S2
      COMMON/evl___SIMPLE/ISIM,OPS(20),S(20),S2(20)
      simple_expression = 0.0 ! init
      ISIM=ISIM+1
      IF (ISIM.GT.20) THEN
        REASON='TOO MUCH NESTING'
        ERR=POS
        RETURN
      ENDIF
      S(ISIM)=eval_TERM()
      IF (ERR.GT.0) RETURN
      DO WHILE (CH.EQ.'*'.OR.CH.EQ.'/')
        OPS(ISIM)=CH
        CALL eval_NEXTCH
        IF (OPS(ISIM).EQ.'*') THEN
          S(ISIM)=S(ISIM)*eval_TERM()
          IF (ERR.GT.0) RETURN
        ELSE
          S2(ISIM)=eval_TERM()
          IF (S2(ISIM).EQ.0) THEN
            REASON='DIVIDE OVERFLOW'
            ERR=POS
            RETURN
          ENDIF
          S(ISIM)=S(ISIM)/S2(ISIM)
          IF (ERR.GT.0) RETURN
        ENDIF
      ENDDO
      SIMPLE_EXPRESSION=S(ISIM)
      ISIM=ISIM-1
      RETURN
      END
      subroutine spawn_nowait(command,pid,ier)
      character command*(*)
      integer   pid
      integer   ier
      integer*4 lib$spawn
      integer   length
      integer   status
      integer   flags
      flags = 1 + 16
      status=lib$spawn(command(1:length(command)),'NL:',,flags,,pid)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
      subroutine str_1substitute(source,old,new,destination)
      implicit none
      character source*(*)     ! input
      character old*(*)        ! string to change. No Empty string
      character new*(*)        ! into this one.    Empty string allowed
      character destination*(*)! output
      integer   length
      external  length
      integer   KL         ! length old
      integer   i
      integer   KN         ! length new
      integer   K
      integer   L
      character temp*1024   ! scratch
      integer   ls
      ls = length(source)
      if(ls.eq.0) then
        destination = source(1:ls)
        return
      endif
      KL = len(old)-1
      if(KL.le.0) then
        destination = source(1:ls)
        return
      endif
      i = index(source(1:ls),old(1:KL))
      if(i.eq.0) then
        destination = source(1:ls)
        return
      endif
      KN = len(new) - 1
      if(KN.lt.0) then
        destination = source(1:ls)
        return
      endif
      if(kn.eq.0) then
        if(i.gt.1) then
          destination = source(1:i-1)//source(i+KL:ls)
        else
          destination = source(i+KL:ls)
        endif
      else
        if(i.gt.1) then
          destination = source(1:i-1)//new(1:kn)//source(i+KL:ls)
        else
          destination = new(1:kn)//source(i+KL:ls)
        endif
      endif
      return
      end
      subroutine str_2integer(n1,n2,s,dest)
      implicit none
      integer   n1,n2
      character s*(*)
      character dest*(*)
      integer ir(2)
      ir(1) = n1
      ir(2) = n2
      call str_iarray(2,ir,s,dest)
      return
      end
      subroutine str_2integer_write(unit,n1,n2,s)
      implicit none
      integer   unit
      integer   n1,n2
      character s*(*)
      character line*256
      call str_2integer(n1,n2,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_2real(r1,r2,s,dest)
      implicit none
      real      r1,r2
      character s*(*)
      character dest*(*)
      real      r(2)
      r(1) = r1
      r(2) = r2
      call str_array(2,r,s,dest)
      return
      end
      subroutine str_2real_write(unit,r1,r2,s)
      implicit none
      integer   unit
      real      r1,r2
      character s*(*)
      character line*256
      call str_2real(r1,r2,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_3integer(n1,n2,n3,s,dest)
      implicit none
      integer   n1,n2,n3
      character s*(*)
      character dest*(*)
      integer ir(3)
      ir(1) = n1
      ir(2) = n2
      ir(3) = n3
      call str_iarray(3,ir,s,dest)
      return
      end
      subroutine str_3integer_write(unit,n1,n2,n3,s)
      implicit none
      integer   unit
      integer   n1,n2,n3
      character s*(*)
      character line*256
      call str_3integer(n1,n2,n3,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_array(n,r,s,dest)
      implicit none
      integer   n
      real      r(n)
      character s*(*)
      character dest*(*)
      integer   lenstr
      integer   ier
      character local*20
      integer   i
      logical   special
      character hek*20
      integer   L
      dest = s
      do i=1,n
        hek(i:i) = '#'
      enddo
      special = (index(s,hek(1:n)).eq.0)
      if(index(s,'#').eq.0) then
        do i=1,n
          dest = dest(1:lenstr(dest))//' #'
        enddo
        special = .true.
      endif
      if(special) then
        do i=1,n
          call str_real_internal(r(i),local,L)
          call str_1substitute(dest,'#;',local(1:L)//';',dest)
        enddo
      else
        do i=n,1,-1
          call str_real_internal(r(i),local,L)
          call str_substitute(dest,hek(1:i)//';',local(1:L)//';',dest)
        enddo
      endif
      return
      end
      subroutine str_array_write(unit,n,r,s)
      implicit none
      integer   unit
      integer   n
      real      r(n)
      character s*(*)
      character line*256
      call str_array(n,r,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_collapse(source,destination)
      implicit none
      character source*(*)
      character destination*(*)
      call str_substitute(source,' $','$',destination)
      end
      subroutine str_compress(source,destination)
      implicit none
      character source*(*)
      character destination*(*)
      integer   length
      external  length
      integer   ldo
      integer   ldn
      call str_leading(source,destination)
      ldn = length(destination)
      ldo = 0
      do while(ldo.ne.ldn)
        call str_substitute(destination,'  $',' $',destination)
        ldo = ldn
        ldn = length(destination)
      enddo
      return
      end
      subroutine str_extract(source,n,destination)
      implicit none
      character source*(*)
      integer   n
      character destination*(*)
      character line*256
      integer   p1,p2
      integer   i
      call str_compress(source,line)
      destination = ' '
      if(n.le.0) return
      p1 = 1
      p2 = index(line(p1:),' ')
      do i=2,n
        p1 = p1+p2
        p2 = index(line(p1:),' ')
      enddo
      if (p2.gt.0) then
        destination = line(p1:p1+p2-1)
      else
        destination = ' '
      endif
      return
      end
      subroutine str_flush
      implicit none
      integer   unit
      integer   wrap
      integer   lb
      integer   indent
      integer   paragraph_length
      character paragraph_string*80
      character str_buffer*256
      common /str___buf/ unit,wrap,lb,indent,paragraph_length,
     1 paragraph_string,str_buffer
      character cc*1
      if(lb.gt.0) then
        inquire(unit=unit,carriagecontrol=cc)
        if(cc.eq.'L') then
          write (unit,600) str_buffer(1:lb)
600       format(<indent>x,a)
        else
          write (unit,610) str_buffer(1:lb)
610       format(1x,<indent>x,a)
        endif
        lb = 0
      endif
      return
      end
      subroutine str_header(source,field,new_source)
      implicit none
      character source*(*)
      character field*(*)
      character new_source*(*)
      character line*256
      integer   i
      call str_leading(source,line)
      i = index(line,' ')
      if(i.gt.1) then
        field = line(1:i-1)
        call str_leading(line(i:),new_source)
      else
        field = ' '
        new_source = line
      endif
      return
      end
      subroutine str_iarray(n,ir,s,dest)
      implicit none
      integer   n
      integer   ir(n)
      character s*(*)
      character dest*(*)
      integer   lenstr
      integer   length
      integer   ier
      character local*20
      integer   i
      logical   special
      character hek*20
      integer   L
      dest = s
      do i=1,n
        hek(i:i) = '#'
      enddo
      special = (index(s,hek(1:n)).eq.0)
      if(index(s,'#').eq.0) then
        do i=1,n
          dest = dest(1:lenstr(dest))//' #'
        enddo
        special = .true.
      endif
      if(special) then
        do i=1,n
          write (local,*,iostat=ier) ir(i)
          call str_leading(local,local)
          L = length(local)
          call str_1substitute(dest,'#;',local(1:L)//';',dest)
        enddo
      else
        do i=n,1,-1
          write (local,*,iostat=ier) ir(i)
          call str_leading(local,local)
          L = length(local)
          call str_substitute(dest,hek(1:i)//';',local(1:L)//';',dest)
        enddo
      endif
      return
      end
      subroutine str_integer(n,s,dest)
      implicit none
      integer   n
      character s*(*)
      character dest*(*)
      integer   length
      integer   lenstr
      integer   ier
      character local*20
      integer   L
      dest = s
      if(index(dest,'#').eq.0) then
        dest = dest(1:lenstr(dest))//' #'
      endif
      write (local,*,iostat=ier) n
      call str_leading(local,local)
      L = length(local)
      call str_substitute(dest,'#;',local(1:L)//';',dest)
      return
      end
      subroutine str_integer_write(unit,n,s)
      implicit none
      integer   unit
      integer   n
      character s*(*)
      character line*256
      call str_integer(n,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_leading(source,destination)
      implicit none
      character source*(*)
      character destination*(*)
      integer   length
      external  length
      integer   i
      i = 1
      if(length(source).gt.0) then
        do while(source(i:i).eq.' ')
          i = i + 1
        enddo
      endif
      destination = source(i:)
      return
      end
      subroutine str_logical(b,s,dest)
      implicit none
      logical   b
      character s*(*)
      character dest*(*)
      integer   lenstr
      dest = s
      if(index(dest,'#').eq.0) then
        dest = dest(1:lenstr(dest))//' #'
      endif
      if(b) then
        call str_substitute(dest,'#;','True;',dest)
      else
        call str_substitute(dest,'#;','False;',dest)
      endif
      return
      end
      subroutine str_logical_out(b,s)
      implicit none
      logical   b
      character s*(*)
      character line*256
      call str_logical(b,s,line)
      call str_out(line)
      return
      end
      subroutine str_matrix_write(unit,matrix,s1,s2,s3)
      implicit none
      integer   unit
      real      matrix(3,3)
      character s1*(*)
      character s2*(*)
      character s3*(*)
      real      v(3)
      call row2vec(1,matrix,v)
      call str_vector_write(unit,v,s1)
      call row2vec(2,matrix,v)
      call str_vector_write(unit,v,s2)
      call row2vec(3,matrix,v)
      call str_vector_write(unit,v,s3)
      return
      end
      subroutine str_num(n,s,result)
      implicit none
      integer   n
      character s*(*)
      character result*(*)
      integer   length
      character h*10
      integer   lh
      result = s
      if(index(result,'#').eq.0) then
        result = '# '//result
      endif
      if(n.eq.0) then
        call str_substitute(result,'#;','no;',result)
      else if(n.eq.1) then
        call str_substitute(result,'#;','one;',result)
      else
        call str_integer(n,result,result)
      endif
      if(n.eq.1) then
        call str_substitute(result,'^;',';',result)
      else
        call str_substitute(result,'^;','s;',result)
      endif
      call str_compress(result,result)
      return
      end
      subroutine str_num_out(n,s)
      implicit none
      integer   unit
      integer   n
      character s*(*)
      character message*256
      call str_num(n,s,message)
      call str_out(message)
      return
      end
      subroutine str_out(string)
      character string*(*)
      integer   unit
      integer   wrap
      integer   lb
      integer   indent
      integer   paragraph_length
      character paragraph_string*80
      character str_buffer*256
      common /str___buf/ unit,wrap,lb,indent,paragraph_length,
     1 paragraph_string,str_buffer
      integer length
      integer   ls
      ls = length(string)
      if(ls.eq.0) return
      if(ls+lb+1+indent+paragraph_length.ge.wrap) call str_flush
      if(lb.eq.0) then
        if(paragraph_length.ne.0) then
          str_buffer = paragraph_string(1:paragraph_length)//
     1     string(1:ls)
          lb = paragraph_length + ls
        else
          str_buffer =  string(1:ls)
          lb = ls
        endif
      else
        str_buffer = str_buffer(1:lb)//' '// string(1:ls)
        lb = lb + ls + 1
      endif
      return
      end
      subroutine str_real(r,s,dest)
      implicit none
      real      r
      character s*(*)
      character dest*(*)
      integer   lenstr
      character local*20
      integer   L
      dest = s
      if (index(dest,'#').eq.0) then
        dest = dest(1:lenstr(dest))//' #'
      endif
      call str_real_internal(r,local,L)
      call str_substitute(dest,'#;',local(1:L)//';',dest)
      return
      end
      subroutine str_real_internal(r,dest,ld)
      implicit none
      real      r
      character dest*(*)
      integer   ld
      integer   real_len_max
      parameter (real_len_max=5)
      integer   real_len
      integer   real_len_stack(real_len_max)
      integer   real_len_p
      character real_form1*7
      character real_form2*7
      common /str___real_common/ real_len,real_len_stack,real_len_p,
     1 real_form1,real_form2
 
      integer   length
      integer   ier
      character local*20
      integer   L
      if(abs(r).lt.0.1.and.abs(r).gt.1.0e-5) then
        write (local,real_form1,iostat=ier) r
      else if(r.eq.0.0) then
        local = '0.0'
      else
        write (local,real_form2,iostat=ier) r
      endif
      call str_leading(local,local)
      l = length(local)
      do while(local(L:L).eq.'0')
        L = L - 1
      enddo
      if(local(L:L).eq.'.'.or.local(L:L).eq.'+') L = L + 1
      dest = local(1:L)
      ld = L
      return
      end
      subroutine str_real_len(n)
      implicit none
      integer   n
      integer   real_len_max
      parameter (real_len_max=5)
      integer   real_len
      integer   real_len_stack(real_len_max)
      integer   real_len_p
      character real_form1*7
      character real_form2*7
      common /str___real_common/ real_len,real_len_stack,real_len_p,
     1 real_form1,real_form2
      data real_len /6/
      data real_len_p /0/
      data real_form1 /'(F14.6)'/
      data real_form2 /'(F20.6)'/
      integer i,m
 
      if(n.eq.0) then
        m = 6
      else if(n.gt.0) then
        m = n
      else
        return
      endif
      if(m.gt.9) m = 9
      if(m.ne.real_len) then
        real_len = m
        write (real_form1,100) m
100     format('(F14.',i1,')')
        write (real_form2,100) m
110     format('(G20.',i1,')')
      endif
      return
      end
      subroutine str_real_write(unit,r,s)
      implicit none
      integer   unit
      real      r
      character s*(*)
      character line*256
      call str_real(r,s,line)
      call str_write(unit,line)
      return
      end
      subroutine str_substitute(source,old,new,destination)
      implicit none
      character source*(*)     ! input
      character old*(*)        ! string to change. No Empty string
      character new*(*)        ! into this one.    Empty string allowed
      character destination*(*)! output
      integer   length
      external  length
      integer   KL         ! length old
      integer   i
      integer   KN         ! length new
      integer   K
      integer   L
      character temp*1024   ! scratch
      integer   ls
      ls = length(source)
      if(ls.eq.0) then
        destination = source(1:ls)
        return
      endif
      KL = len(old)-1
      if(KL.le.0) then
        destination = source(1:ls)
        return
      endif
      i = index(source(1:ls),old(1:KL))
      if(i.eq.0) then
        destination = source(1:ls)
        return
      endif
      KN = len(new) - 1
      if(KN.lt.0) then
        destination = source(1:ls)
        return
      endif
 
      K = 1
      L = 1
      do while(k.le.ls)
        if(source(K:K+KL-1).eq.old(1:KL)) then
          if (kn.gt.0) then
            temp(L:L+KN-1) = new
          endif
          L = L + KN
          K = K + KL
        else
          temp(L:L) = source(K:K)
          L = L + 1
          K = K + 1
        endif
      enddo
      if(L.eq.1) then
        destination = temp(1:1)
      else
        destination = temp(1:L-1)
      endif
      return
      end
      subroutine str_unit(u)
      implicit none
      integer u
      integer   unit
      integer   wrap
      integer   lb
      integer   indent
      integer   paragraph_length
      character paragraph_string*80
      character str_buffer*256
      common /str___buf/ unit,wrap,lb,indent,paragraph_length,
     1 paragraph_string,str_buffer
      data unit   / 6/
      data wrap   /80/
      data lb     / 0/
      data indent / 0/
      data paragraph_length /0/
      integer   page
      call str_flush  ! if there is anything left
      unit = u
      if(unit.eq.6) then
        call get_term_size(wrap,page)
        wrap = min(wrap,80)
      else
        inquire(unit=unit,recl=wrap)
        if(wrap.eq.0) wrap=80
      endif
      wrap = min(wrap,len(str_buffer))
      return
      end
      subroutine str_vector_write(unit,v,s)
      implicit none
      integer   unit
      real      v(3)
      character s*(*)
      call str_array_write(unit,3,v,s)
      return
      end
      subroutine str_write(output_unit,string)
      implicit none
      integer   output_unit
      character string*(*)
      integer   unit
      integer   wrap
      integer   lb
      integer   indent
      integer   paragraph_length
      character paragraph_string*80
      character str_buffer*256
      common /str___buf/ unit,wrap,lb,indent,paragraph_length,
     1 paragraph_string,str_buffer
      integer   lenstr
      character s*256
      character cc*1
      call str_compress(string,s)
      inquire(unit=output_unit,carriagecontrol=cc)
      if(cc.eq.'L') then
        write (output_unit,600) s(1:lenstr(s))
600     format(<indent>x,a)
      else
        write (output_unit,610) s(1:lenstr(s))
610     format(1x,<indent>x,a)
      endif
      return
      end
      character*11 function today()
      call lib$date_time(today)
      return
      end
      subroutine upcase(string1,string2)
      implicit none
      character string1*(*)
      character string2*(*)
      integer   length
      character c*1
      integer   i
      integer   delta
      delta = ichar('a')-ichar('A')
      string2 = string1
      do 10 i=1,length(string2)
        c = string2(i:i)
        if(c.ge.'a'.and.c.le.'z') then
          string2(i:i) = char( ichar(c)-delta)
        endif
10    continue
      return
      end
      subroutine vms_shell(pid,ier)
      integer pid
      integer ier
      integer*4 status,lib$spawn
      status = lib$spawn(,,,,,pid)
      if(.not.status) then
        ier = status
      else
        ier = 0
      endif
      return
      end
