c       ************************************************************************
c       *
c       *   intrin.f -
c       *
c       *   Copyright (c) 1995
c       *
c       *   ETH Zuerich
c       *   Institut fuer Molekularbiologie und Biophysik
c       *   ETH-Hoenggerberg
c       *   CH-8093 Zuerich
c       *
c       *   All Rights Reserved
c       *
c       *   Date of last modification : 95/09/15
c       *   Pathname of SCCS file     : /export/home3/cb/garant-1.0/src/SCCS/s.intrin.f
c       *   SCCS identification       : 1.3
c       *
c       ************************************************************************
c     ==================================================================
c     SYSFUN: Evaluate intrinsic functions of the command interpreter.
c
c             Peter G"untert, 02-08-1994
c     ------------------------------------------------------------------
      subroutine intrin (func,iarg,narg,inum,rnum,cnum,snum,numtyp)
c
      character quote
      parameter (quote='''')
      character*(*) func,snum(*)
      dimension iarg(*),inum(*),rnum(*),numtyp(*)
      complex cnum(*)
      logical match,yes,nostr,havpas
c
      parameter (maxlin=250,maxid=32,maxvar=500)
      character var*(maxid),vardef*(maxlin)
      common /vardat/nvar
     *       /vdch/var(maxvar),vardef(maxvar)
      character extnsn*(maxid)
      common /macdat/extnsn
c
      character*(*) str*(maxlin),path*(maxlin),dirend*2
      data dirend/'/]'/
c
      i1=iarg(1)
      n1=numtyp(i1)
c     -------------------------------- program-specific system functions
      call sysfun (func,iarg,narg,inum,rnum,cnum,snum,numtyp)
      if (numtyp(i1).ge.1 .and. numtyp(i1).le.4) return
      numtyp(i1)=n1
c     ------------------- intrinsic functions of the command interpreter
      if (narg.eq.1) then
c       .......................... functions with one character argument
        if (numtyp(i1).eq.4) then
          if (func.eq.'lenstr') then
            numtyp(i1)=1
          else if (func.eq.'length') then
            do 301 k=nvar,1,-1
  301         if (snum(i1)(1:inum(i1)).eq.var(k)) go to 302
  302       if (k.gt.0 .and. vardef(k).ne.'NULL') then
              nc=0
              nostr=.true.
              do 305 j=1,lenstr(vardef(k))
                if (vardef(k)(j:j).eq.quote) nostr=.not.nostr
  305           if (nostr .and. vardef(k)(j:j).eq.',') nc=nc+1
              inum(i1)=nc+1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else if (func.eq.'exist') then
            do 310 k=nvar,1,-1
  310         if (snum(i1)(1:inum(i1)).eq.var(k)) go to 320
  320       if (k.gt.0) then
              inum(i1)=1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else if (func.eq.'def') then
            do 330 k=nvar,1,-1
  330         if (snum(i1)(1:inum(i1)).eq.var(k)) go to 340
  340       if (k.gt.0 .and. vardef(k).ne.'NULL') then
              inum(i1)=1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else if (func.eq.'file') then
            inquire (file=snum(i1)(1:inum(i1)),exist=yes)
            if (yes) then
              inum(i1)=1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else if (func.eq.'opened') then
            inquire (file=snum(i1)(1:inum(i1)),opened=yes)
            if (yes) then
              inum(i1)=1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else if (func.eq.'macro') then
            yes=.false.
            havpas=.false.
            do 410 l=1,len(dirend)
              havpas=havpas .or. 
     *               index(snum(i1)(1:inum(i1)),dirend(l:l)).gt.0
  410         continue
            if (havpas) then
              str=snum(i1)(1:inum(i1))//extnsn
            else
              do 420 k=nvar,1,-1
  420           if (var(k).eq.'path') go to 430
              go to 450
  430         path=vardef(k)
            end if
  440       continue
              if (.not.havpas) then
                call lefstr(path)
                lpath=index(path,',')-1
                if (lpath.lt.0) then
                  lpath=lenstr(path)
                  if (lpath.lt.1) go to 450
                end if
                str=path
                path=str(lpath+2:)
                if (lpath.eq.0) go to 440
                str(lpath+1:)='/'//snum(i1)(1:inum(i1))//extnsn
              end if
              inquire (file=str,exist=yes)
            if (.not. (havpas .or. yes)) go to 440
  450       if (yes) then
              inum(i1)=1
            else
              inum(i1)=0
            end if
            numtyp(i1)=1
          else
            go to 900
          end if
          go to 800
        end if
        go to 900
c     ------------------------------------- functions with two arguments
      else if (narg.eq.2) then
        i2=iarg(2)
        if (func.eq.'match') then
          if (numtyp(i1).ne.4 .or. numtyp(i2).ne.4) go to 900
          if (match(snum(i1)(1:inum(i1)),snum(i2)(1:inum(i2)))) then
            inum(i1)=1
          else
            inum(i1)=0
          end if
          numtyp(i1)=1
        else
          go to 900
        end if
c     -------------------------------------------------- other functions
      else
        go to 900
      end if
  800 return
c     ------------------------------------------------------------ error
  900 numtyp(i1)=0
      end
c     ==================================================================
c     MATCH:    Does the string S match the string O which may
c               contain wildcards?
c
c               The two possible wildcards are:
c                 "?" ... matches exactly one character
c                 "*" ... matches any number (including zero)
c                         of characters
c               The two strings S and O will not be changed.
c
c               Written in standard FORTRAN-77.
c               Peter Guentert, 28-11-1988
c     ------------------------------------------------------------------
      logical function match(s,o)
c
      character*(*) s,o
      logical fix
c
      io=lenstr(o)
      is=lenstr(s)
      if (io.eq.0) then
        match=.true.
        return
      else if (is.eq.0) then
        match=.true.
        return
      end if
c
      if (index(o,'*').eq.0) then
        match=is.eq.io
        if (.not.match) return
        do 5 i=1,is
          match=s(i:i).eq.o(i:i) .or. o(i:i).eq.'?'
    5     if (.not.match) return
        return
      end if
c 
      fix=.true.
      jo=1
      js=1
   10 if (jo.le.io) then
        if (o(jo:jo).eq.'*') then
          fix=.false.
          jo=jo+1
        else
          j=index(o(jo:io),'*')-1
          if (j.lt.0) j=io-jo+1
          if (fix) then
            imax=js
          else
            imax=is-j+1
          end if
          do 30 i=js,imax
            do 20 l=jo,jo+j-1
              if (o(l:l).ne.'?') then
                k=i+l-jo
                if (o(l:l).ne.s(k:k)) go to 30
              end if
   20         continue
            jo=jo+j
            js=i+j
            fix=.true.
            go to 10
   30       continue
          match=.false.
          return
        end if
      go to 10
      end if
      match=(js.gt.is .or. (.not. fix))
      end