C @(#)express.for	19.1 (ESO-DMD) 02/25/03 14:01:06
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
      SUBROUTINE EXPCLE(INSTRG,OUTSTR,MAXSIZ,COUNT,ATOM,LATOM)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C 
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: K.Banse
C
C.IDENTIFICATION
C  subroutine EXPCLE  			version 3.00 	881209
C  K. Banse   				ESO - Garching
C
C.KEYWORDS
C  parsing, arithmetic + logical expression
C
C.PURPOSE
C   replace all constants by 'C', all frame names by 'F',all 
C  1-arg functions by 'P' and all 2-arg functions by 'Q',
C  finally truncate all operators to one character.
C
C.ALGORITHM
C  use routine EXPATM to extract the objects listed above
C  and test for number via GENNUM, for function via LGFUNC
C  everything else is considered a frame name (unless it's a delimiter)
C  only the following operators are converted:
C  ** -> `, .OR. -> |, .AND. -> ~, .NOT. -> -1 .XOR. -> !
C
C.INPUT/OUTPUT
C  call as EXPCLE(INSTRG,OUTSTR,MAXSIZ,COUNT,ATOM,LATOM)
C
C  input par:
C  INSTRG:	char.exp. 	input string
C  MAXSIZ:	I*4		max. length of each ATOM
C
C  output par:
C  OUTSTR: 	char.exp. 	"cleaned" output string
C  COUNT: 	I*4  		no. of operands in expression
C    				should be > 0,
C    				if = -1, wrong syntax !!
C    				if = -2, overflow for ATOM
C  ATOM: 	char. array 	holds extracted operands in original form
C  LATOM: 	I*4 array 	holds length of each ATOM
C
C.VERSION
C  990205 
C 
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C 
      CHARACTER*(*) INSTRG,OUTSTR,ATOM(23)
      CHARACTER MYSTRG*324,DELIM*1,WC*1
C 
      INTEGER MAXSIZ,LATOM(*)
      INTEGER COUNT,OO,II,LL,N,MINFLG
      INTEGER LOGFNC,GENNUM,LGFUNC
C
C  initialize
      II = 1
      N = 1
      LL = LEN(INSTRG)
      IF (LL.GT.320) THEN                      !max. size currently 320
         COUNT = -2
         RETURN
      ENDIF
C 
10    IF (N.GT.LL) GOTO 30   
C 
      IF (INSTRG(N:N).EQ.' ') THEN
         N = N + 1                                    !move on to next char.
         IF ((N.GT.LL) .OR. (INSTRG(N:N).EQ.' '))
     +      GOTO 30                                   !that's the end ...
      ELSE IF (INSTRG(N:N+1).EQ.'**') THEN
         MYSTRG(II:II) = '`'
         II = II + 1
         N = N + 2
      ELSE IF (INSTRG(N:N+1).EQ.'+-') THEN
         MYSTRG(II:II) = '-'
         II = II + 1
         N = N + 2
      ELSE IF (INSTRG(N:N+1).EQ.'-+') THEN
         MYSTRG(II:II) = '-'
         II = II + 1
         N = N + 2
      ELSE IF (INSTRG(N:N+1).EQ.'--') THEN
         MYSTRG(II:II) = '+'
         II = II + 1
         N = N + 2
      ELSE IF (INSTRG(N:N).EQ.'.') THEN
         IF (INSTRG(N:N+3).EQ.'.OR.') THEN
            MYSTRG(II:II) = '|'
            II = II + 1
            N = N + 4
         ELSE IF (INSTRG(N:N+4).EQ.'.AND.') THEN
            MYSTRG(II:II) = '~'
            II = II + 1
            N = N + 5
         ELSE IF (INSTRG(N:N+4).EQ.'.XOR.') THEN
            MYSTRG(II:II) = '!'
            II = II + 1
            N = N + 5
         ELSE IF (INSTRG(N:N+4).EQ.'.NOT.') THEN
            MYSTRG(II:II+2) = '-1!'
            II = II + 3
            N = N + 5
         ELSE
            MYSTRG(II:II) = INSTRG(N:N)
            II = II + 1
            N = N + 1
         ENDIF
C 
      ELSE
         MYSTRG(II:II) = INSTRG(N:N)
         II = II + 1
         N = N + 1
      ENDIF
C 
      GOTO 10
C
C  we reached the end of the input string
30    LL = II
      MYSTRG(LL:LL) = ' '                    !mark the end by a 'blank'
      II = 1
      OO = 1  
      MINFLG = 0
      COUNT = 1
C
C  extract atoms from left to right  
99    IF (II.GT.LL) THEN
         IF (MINFLG.EQ.1) THEN             !append closing parenthesis
            OUTSTR(OO:OO) = ')'
            OO = OO + 1
         ENDIF  
         GOTO 1000
      ENDIF
C 
      CALL EXPATM(MYSTRG(II:),DELIM,ATOM(COUNT),LATOM(COUNT))
      IF (LATOM(COUNT).LT.0) THEN
         GOTO 9900
C
C  in second pass the delimiter only is returned  
      ELSE IF (LATOM(COUNT).EQ.0) THEN
         IF (DELIM.EQ.' ') THEN
            IF (MINFLG.EQ.1) THEN  
               OUTSTR(OO:OO) = ')'
               OO = OO + 1
            ENDIF  
            GOTO 1000                                     !go + finish
         ENDIF
C
         IF (DELIM.EQ.'-') THEN
            IF (OO.EQ.1) THEN
               ATOM(COUNT) = '0 '
               LATOM(COUNT) = 1
               COUNT = COUNT + 1
               OUTSTR(OO:) = 'C'
               OO = OO + 1
C
            ELSE 
               WC = OUTSTR(OO-1:OO-1)
               IF ((WC.EQ.'(') .OR. (WC.EQ.',')) THEN     !look for (- or ,-
                  ATOM(COUNT) = '0 '
                  LATOM(COUNT) = 1
                  COUNT  = COUNT + 1
                  OUTSTR(OO:) = 'C'
                  OO = OO + 1
C
               ELSE IF ((WC.EQ.'*') .OR. (WC.EQ.'/')) THEN
                  OUTSTR(OO:OO) = '('
                  ATOM(COUNT) = '0 '
                  LATOM(COUNT) = 1
                  COUNT = COUNT + 1
                  OUTSTR(OO+1:OO+1) = 'C'
C                                 set minus flag, since ) still to be added
                  OO = OO + 2
                  MINFLG = 1
               ENDIF
            ENDIF
C
         ELSE IF (DELIM.EQ.'+') THEN
            IF ( (OO.EQ.1) .OR.
     +           ( (OO.GT.1) .AND. (OUTSTR(OO-1:OO-1).EQ.'(') ) ) THEN
               II = II + 1
               GOTO 99
            ENDIF
         ENDIF
C
         OUTSTR(OO:OO) = DELIM
         OO = OO + 1
         II = II + 1
C
      ELSE IF (LATOM(COUNT).GT.MAXSIZ) THEN               !check for overflow
         GOTO 9910 
C
C  in first pass the atom + delimiter is returned
      ELSE
         IF (GENNUM(ATOM(COUNT)).EQ.1) THEN               !it's a number
             OUTSTR(OO:OO) = 'C'
         ELSE
            IF (DELIM.NE.'(') THEN                        !it's a frame
               OUTSTR(OO:OO) = 'F'
            ELSE
               LOGFNC = LGFUNC(ATOM(COUNT))
               IF (LOGFNC.EQ.0) THEN
                  GOTO 9900
               ELSE
                  IF (LOGFNC.EQ.1) THEN                !it's 1-arg function
                     OUTSTR(OO:OO) = 'P'
                  ELSE                                 !it's 2-arg function
                     OUTSTR(OO:OO) = 'Q'
                  ENDIF
                  CALL UPCAS(ATOM(COUNT),ATOM(COUNT))
               ENDIF
            ENDIF
         ENDIF
C
         OO = OO + 1
         II = II + LATOM(COUNT) 
         COUNT = COUNT + 1
C
         IF (MINFLG.EQ.1) THEN  
            MINFLG = 0  
            OUTSTR(OO:OO) = ')'
            OO = OO + 1
         ENDIF
      ENDIF
      GOTO 99                                  !pull out next atom
C
C  finished
1000  OUTSTR(OO:) = ' '
      COUNT = COUNT - 1
C
C  now we only have to check, that parentheses match
      IF (COUNT.GT.0) THEN
         LL = 0
         DO 1060 N = 1,OO
            IF (OUTSTR(N:N).EQ.'(') THEN
               LL = LL + 1
            ELSE IF (OUTSTR(N:N).EQ.')') THEN
               LL = LL - 1
            ENDIF
1060     CONTINUE 
         IF (LL.NE.0) GOTO 9900
      ENDIF
      RETURN
C 
9900  COUNT = -1                       !invalid syntax...
      RETURN
C 
9910  COUNT = -2                       !buffer overflow...
      RETURN
      END


      SUBROUTINE EXPATM(INPUT,DELIM,ATOM,LATOM)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine EXPATM  		version 2.50	880126
C  K. Banse   			ESO - Garching
C  					2.60	890922
C
C.KEYWORDS
C  parsing, atoms of an arithmetic expression
C
C.PURPOSE
C  extract atoms and their delimiters from an arithmetic expression
C
C.ALGORITHM
C  straight forward
C
C.INPUT/OUTPUT
C  call as EXPATM(INPUT,DELIM,ATOM,LATOM)
C
C  input par:
C  INPUT: 	char.exp. 	input string
C
C  output par:
C  DELIM: 	char.exp. 	delimiter of returned atom
C  NOBL: 	I*4  		no. of blanks in front of atom
C  ATOM: 	char.exp	extracted operand
C  LATOM: 	I*4		length of ATOM
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C 
      CHARACTER*(*) INPUT,ATOM
      CHARACTER*1 DELIM,SNGC,LIMITS(10)

      INTEGER LATOM
      INTEGER NLIM,N,KK,II
C
      DATA NLIM/10/
      DATA 
     +   LIMITS /' ','*','/','(',')','!','|','~','`',','/
C
      LATOM = 0
      ATOM = ' '
      II = 0
C 
100   II = II + 1
      DELIM = INPUT(II:II)
C 
      IF (DELIM.EQ.'"') THEN                    !if "abc...
         KK = INDEX(INPUT(II+1:),'"')           !move already to "abc... "
         IF (KK.LE.1) GOTO 999
         LATOM = KK + 1
         II = LATOM
         GOTO 100
C 
      ELSE IF (DELIM.EQ.'[') THEN               !if abc[ 
         II = INDEX(INPUT,']')                  !move already to abc[...]
         IF (II.LE.1) GOTO 999
         LATOM = II
         GOTO 100
      ENDIF         
C 
C  first look for ddd.Eeee numbers
      IF ( (DELIM.EQ.'+') .OR. (DELIM.EQ.'-') ) THEN
         IF (LATOM.GT.1) THEN
            SNGC = INPUT(LATOM:LATOM)
            IF ( (SNGC.EQ.'E') .OR. (SNGC.EQ.'e') .OR.
     +           (SNGC.EQ.'D') .OR. (SNGC.EQ.'d') ) THEN
               DO 110,KK=1,LATOM-1
                  SNGC = INPUT(KK:KK)
                  IF ( (SNGC.NE.'.') .AND.
     +                 ((SNGC.LT.'0').OR.(SNGC.GT.'9')) ) GOTO 200
110            CONTINUE
C 
               LATOM = LATOM + 1
               GOTO 100
            ENDIF
         ENDIF
C 
200      IF (LATOM.GT.0) ATOM = INPUT(1:LATOM)//' '
         RETURN
      ENDIF
C 
      DO 300,N=1,NLIM 
         IF (DELIM.EQ.LIMITS(N)) THEN
            IF (LATOM.GT.0) ATOM = INPUT(1:LATOM)//' '
            RETURN
         ENDIF
300   CONTINUE
C
C  no delimiter - loop more
      LATOM = LATOM + 1
      GOTO 100
C
999   LATOM = -1			!problems...
      RETURN
C 
      END


      SUBROUTINE EXPPOL(INSTRG,OUTSTR,STATUS)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine EXPPOL 		version 2.21 	821103
C  K. Banse   			ESO - Garching
C
C.KEYWORDS
C  polish reverse notation
C
C.PURPOSE
C   convert an expression in "normal" algebraic notation to polish
C   reversed notat
C
C.ALGORITHM
C  use a stack to store temporary data
C  functions as P(A+B) will be converted to PAB+) to indicate 
C  range of function
C
C.INPUT/OUTPUT
C  call as EXPPOL(INSTRG,OUTSTR,STATUS)
C
C  input par:
C  INSTRG: 	char.exp. 	input string
C
C  output par:
C  OUTSTR: 	char.exp. 	output string in polish reversed notation
C  STATUS: 	I*4  		return status
C    				= 0, o.k., else trouble...
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C 
      CHARACTER*(*) INSTRG,OUTSTR
      CHARACTER*1 NCHAR,STOP
C 
      INTEGER STATUS
      INTEGER FLAG,INEXT,ONEXT,SRVAL,STAPR,INPR
      INTEGER STVAL,TYPE,LL
C 
      SAVE
C
      LL = INDEX(INSTRG,' ') - 1
      STATUS = 0
C
C  init stack
      CALL EXPSTA
C
C  extract operators and operands from left to right
      INEXT  = 1
      ONEXT  = 1
C                                          end of string reached
10    IF (INEXT.GT.LL) GOTO 70
      NCHAR = INSTRG(INEXT:INEXT)
C                                          classify token
      CALL EXPCLA(NCHAR,TYPE,INPR,STAPR)
      INEXT = INEXT + 1
      GOTO (20,30,60),TYPE
C
C  number/variable
20    OUTSTR(ONEXT:ONEXT) = NCHAR
      ONEXT = ONEXT + 1
      GOTO 10
C
C  operator
C
C  if NCHAR = closing parenthese, unwind stack
C 
30    IF (NCHAR.EQ.')') THEN  
C                                                     pop from stack
40       CALL EXPPOP(STVAL,STOP,FLAG)  
         IF (FLAG.EQ.-1) GOTO 80  
         IF (STOP.EQ.'(') GOTO 10
         IF (STOP.EQ.'[') THEN
C                                               write ')' for end-of-function
            OUTSTR(ONEXT:ONEXT) = NCHAR
            ONEXT  = ONEXT + 1
            GOTO 10
C                                      store stack operator in output string
         ELSE  
            OUTSTR(ONEXT:ONEXT) = STOP
            ONEXT  = ONEXT + 1
            GOTO 40
         ENDIF
      ENDIF
C
C  if NCHAR = closing comma, unwind stack till '['
      IF (NCHAR.EQ.',') THEN
50       CALL EXPPEP(STVAL,STOP,FLAG)              !look at stack
         IF (FLAG.EQ.-1) GOTO 80
         IF (STOP.EQ.'[') THEN  
            GOTO 10
         ELSE                                      !pop stack
            CALL EXPPOP(SRVAL,STOP,FLAG)  
            OUTSTR(ONEXT:ONEXT) = STOP
            ONEXT  = ONEXT + 1
            GOTO 50
         ENDIF
      ENDIF
C
C  all other characters here...            look what's on top of the stack
C 
      CALL EXPPEP(STVAL,STOP,FLAG)  
      IF (FLAG.EQ.-1) THEN
C                                          push on stack always
          CALL EXPPSH(STAPR,NCHAR,FLAG)
          GOTO 10
      ENDIF
C 
C  if input precedence > stack value, push stack precedence on stack
      IF (INPR.GT.STVAL) THEN
         CALL EXPPSH(STAPR,NCHAR,FLAG)
         GOTO 10
      ELSE
         CALL EXPPOP(STVAL,STOP,FLAG)
         OUTSTR(ONEXT:ONEXT) = STOP
         ONEXT  = ONEXT + 1
         GOTO 30
      ENDIF
C
C  function
60    OUTSTR(ONEXT:ONEXT) = NCHAR
      ONEXT  = ONEXT + 1
C                                push symbol '[' on stack to mark function start
      CALL EXPPSH(0,'[',FLAG)
C                                and skip following '(' ...
      INEXT  = INEXT + 1
      GOTO 10
C
C  end of input string reached
C 
70    CALL EXPPOP(STVAL,STOP,FLAG)
C                                          stack empty - we're done
      IF (FLAG.EQ.-1) THEN
         OUTSTR(ONEXT:) = ' '
         RETURN
      ENDIF
C 
      OUTSTR(ONEXT:ONEXT) = STOP
      ONEXT  = ONEXT + 1  
      GOTO 70
C
C  problems, problems,...
80    STATUS = 1
      RETURN
      END

      SUBROUTINE EXPRDC(INPUT,OUTPUT,OPERA,P)
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.IDENTIFICATION
C  subroutine EXPRDC
C.AUTHOR
C  K. Banse   ESO - Garching
C
C.KEYWORDS
C  polish notation, arithmetic expression
C
C.PURPOSE
C  extract from a given polish expression the next binary subexpression
C  and reduce the expression accordingly (replace subexpression
C  by result)
C
C.ALGORITHM
C  look for instances of 'X X op' or 'P X )' or 'Q X X )'
C  where X either F or C
C
C.INPUT/OUTPUT
C  call as EXPRDC(INPUT,OUTPUT,OPERA,P)
C
C  input par:
C  INPUT: 	char.exp. 	input string
C
C  output par:
C  OUTPUT: 	char.exp. 	"reduced" output string
C  OPERA: 	char.exp. 	subexpression to execute next
C  P:  		I*4  		starting index of subexpression in input string
C				= -1, if something wrong
C
C.VERSION
C 2.32		830502		original
C 2.50		930211		return error code
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C 
      CHARACTER*(*) INPUT,OUTPUT,OPERA
      CHARACTER TASK*4
C 
      INTEGER P,LL
C
C  start here looking at the string 
      LL = INDEX(INPUT,' ') - 1
      IF (LL.LE.0) LL = LEN(INPUT)
      OUTPUT = ' '
      P = 1
C
20    TASK = INPUT(P:)
C
C  look for 1-arg functions: P X )
      IF (TASK(1:1).EQ.'P') THEN
         IF (TASK(3:3).NE.')') GOTO 40
         IF ((TASK(2:2).NE.'C') .AND. (TASK(2:2).NE.'F')) GOTO 40
         GOTO 30
      ENDIF
C
C  look for 2-arg functions: Q X X )
      IF (TASK(1:1).EQ.'Q') THEN
         IF (TASK(4:4).NE.')') GOTO 40
         IF ((TASK(2:2).NE.'C') .AND. (TASK(2:2).NE.'F')) GOTO 40
         IF ((TASK(3:3).NE.'C') .AND. (TASK(3:3).NE.'F')) GOTO 40
         GOTO 30
      ENDIF
C
C  look for OPERA: X X op
      IF ((TASK(1:1).NE.'C') .AND. (TASK(1:1).NE.'F')) GOTO 40
      IF ((TASK(2:2).NE.'C') .AND. (TASK(2:2).NE.'F')) GOTO 40
      IF ((TASK(3:3).EQ.'C') .OR. (TASK(3:3).EQ.'F')) GOTO 40
      IF ((TASK(3:3).EQ.'P') .OR. (TASK(3:3).EQ.'Q')) GOTO 40
C
C  valid OPERA found - copy first/last part
30    IF (P.GT.1) OUTPUT(1:P-1) = INPUT(1:)  
      IF (TASK(1:1).NE.'Q') THEN
         OUTPUT(P+1:) = INPUT(P+3:)//' '  
         TASK(4:4)  = ' '
      ELSE
         OUTPUT(P+1:) = INPUT(P+4:)//' '
      ENDIF
C
C  replace the OPERA by result
      IF ((TASK(1:2).EQ.'CC') .OR. (TASK(1:2).EQ.'PC') .OR.
     +   (TASK(1:3).EQ.'QCC')) THEN
         OUTPUT(P:P) = 'C'
      ELSE
         OUTPUT(P:P) = 'F'
      ENDIF
C
C  copy TASK into OPERA
      OPERA = TASK//' '
      RETURN
C
C  no valid OPERA, move on
40    P = P + 1
      IF (P.GT.LL) THEN
         P = -1                             !indicate problem to caller...
         RETURN
      ELSE
         GOTO 20
      ENDIF
C
      END

      SUBROUTINE EXPSTA
C
      IMPLICIT NONE
C
      INTEGER OVF,PNTR
      INTEGER IA(40)
C 
      CHARACTER*1 CA(40)
C 
      COMMON /STACKI/IA,PNTR,OVF
      COMMON /STACKC/CA
C
C  pointer to top of stack (max. 40 operands on line of 80 characters...)
      PNTR   = 0  
      OVF    = 40
C
      RETURN
      END

      SUBROUTINE EXPPSH(IVAL,CHAR,FLAG)
C
      IMPLICIT NONE
C 
      INTEGER IVAL,FLAG
      INTEGER IA(40),OVF,PNTR
C 
      CHARACTER*1 CHAR
      CHARACTER*1 CA(40)
C
      COMMON /STACKI/IA,PNTR,OVF
      COMMON /STACKC/CA
C
      IF (PNTR.GE.OVF) THEN
         FLAG   = +1
         RETURN
      ENDIF
C
C  stack o.k.
      PNTR = PNTR + 1
      CA(PNTR) = CHAR
      IA(PNTR) = IVAL
      FLAG   = 0
C 
      RETURN
      END

      SUBROUTINE EXPPOP(IVAL,CHAR,FLAG)
C
      IMPLICIT NONE
C 
      INTEGER IVAL,FLAG,OVF,PNTR
      INTEGER IA(40)
C 
      CHARACTER*1 CHAR
      CHARACTER*1 CA(40)
C
      COMMON /STACKI/IA,PNTR,OVF
      COMMON /STACKC/CA
C
      IF (PNTR.LE.0) THEN
         FLAG   = -1
         RETURN
      ENDIF
C
C  stack o.k.
      IVAL   = IA(PNTR)
      CHAR   = CA(PNTR)
      PNTR   = PNTR - 1
      FLAG   = 0
C 
      RETURN
      END

      SUBROUTINE EXPPEP(IVAL,CHAR,FLAG)
C
      IMPLICIT NONE
C 
      INTEGER IVAL,FLAG,OVF,PNTR
      INTEGER IA(40)
C 
      CHARACTER*1 CHAR
      CHARACTER*1 CA(40)
C
      COMMON /STACKI/IA,PNTR,OVF
      COMMON /STACKC/CA
C
      IF (PNTR.LE.0) THEN
         FLAG   = -1
         RETURN
      ENDIF
C
C  stack o.k.
      IVAL   = IA(PNTR)
      CHAR   = CA(PNTR)
      FLAG   = 0
C 
      RETURN
      END

      SUBROUTINE EXPCLA(INPUT,TYPE,IPR,SPR)
C
      IMPLICIT NONE
C
      INTEGER IPR,SPR,TYPE
      INTEGER INPR(11),STPR(11),N
C 
      CHARACTER*(*) INPUT
      CHARACTER*1 OPER(11)
C
      DATA  OPER /'+','-','*','/','(',')','`','|','~','!',','/
C 
      DATA INPR/1,1,2,2,4,0,3,3*1,0/
      DATA STPR/1,1,2,2,0,4,3,3*1,0/
C
      IPR    = 0
      SPR    = 0
C
C  is it a constant or a frame?
      IF ((INPUT.EQ.'C') .OR. (INPUT.EQ.'F')) THEN
         TYPE   = 1
         RETURN
      ENDIF
C
C  is it a function?
      IF ((INPUT.EQ.'P') .OR. (INPUT.EQ.'Q')) THEN
         TYPE   = 3
         RETURN
      ENDIF
C
C  compare input with operators  
      TYPE   = 2
      DO 10 N = 1,15
         IF (INPUT.EQ.OPER(N)) THEN
            IPR    = INPR(N)
            SPR    = STPR(N)
            RETURN
          ENDIF
10    CONTINUE
C
      END

      INTEGER FUNCTION LGFUNC(STRING)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C 
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: K.Banse
C
C.IDENTIFICATION
C  integer function LGFUNC
C  K. Banse   				ESO - Garching
C  4.00       900702
C
C.KEYWORDS
C  logical expression
C
C.PURPOSE
C  test, if input represents a FORTRAN function
C
C.ALGORITHM
C  compare string with internal function table
C
C.INPUT/OUTPUT
C  use as LGFUNC(STRING)
C
C  input par:
C  STRING: char.exp.      function string
C
C  return status = 1 if 1-arg function, = 2 if 2-arg function
C                = 0 if no valid function
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      IMPLICIT NONE
C 
      INTEGER    N,PLIM,QLIM
C 
      CHARACTER*(*)    STRING
      CHARACTER*5      PFUNCS(14),QFUNCS(4),TEST
C
      DATA    PFUNCS 
     +     /'SQRT ','LN   ','LOG10','EXP  ','EXP10',
     +     'SIN  ','COS  ','TAN  ','ASIN ','ACOS ',
     +     'ATAN ','INT  ','ABS  ','LOG  '/
      DATA    QFUNCS      /'ATAN2','MIN  ','MAX  ','MOD  '/
      DATA    PLIM      /14/, QLIM /4/
C
C  init return to 0
      LGFUNC = 0
      CALL UPCAS(STRING(1:5),TEST)
C
C  compare input string with existing 1-arg functions
      DO 500 N=1,PLIM
         IF (PFUNCS(N).EQ.TEST) THEN
            LGFUNC = 1
            RETURN
         ENDIF
500   CONTINUE
C
C  compare input string with existing 2-arg functions
      DO 600 N=1,QLIM
         IF (QFUNCS(N).EQ.TEST) THEN
            LGFUNC = 2
            RETURN
         ENDIF
600   CONTINUE
C
      RETURN
      END
