C @(#)express.for 17.1.1.1 (ESO-DMD) 01/25/02 17:40:33 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