C++********************************************************************* C C LOGIFQ.F ADAPTED FOR CHAR. VARIABLES AUG 89 ArDean Leith C UNCONDITIONAL JUMP ADDED SEPT 96 ArDean Leith C IF (...) THEN IMPLEMENTED SEPT 97 ArDean Leith C EXIT ADDED NOV 06 ArDean Leith C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2005 Health Research Inc. * C=* * C=* HEALTH RESEARCH INCORPORATED (HRI), * C=* ONE UNIVERSITY PLACE, RENSSELAER, NY 12144-3455. * C=* * C=* Email: spider@wadsworth.org * 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 the * C=* 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 GNU * C=* General Public License for more details. * C=* * C=* You should have received a copy of the GNU General Public License * C=* along with this program; if not, write to the * C=* Free Software Foundation, Inc., * C=* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. * C=* * C ********************************************************************** C C LOGIFQ(STRING,LABEL,JUMP,IER) C C PURPOSE: EVALUATES STRING SUCH AS: IF(X.LE.5) GOTO LB77 C RETURNS THE LB77, AND A LOGICAL FLAG WHETHER ONE C SHOULD FOLLOW THE GOTO TO THE LABEL LOCATION. C ALSO ACCEPTS STRING SUCH AS: IF (X.LE.5) (X11=9) C AND WILL EVALUATE THE SECOND EXPRESSION BEFORE C RETURNING. C C PARAMETERS: STRING INPUT LINE (SENT) C LABEL LABEL STRING (RETURNED) C JUMP FLAG TO FOLLOW GOTO (RETURNED) C IERR ERROR FLAG (1 IS ERROR) (RETURNED) C C--********************************************************************* SUBROUTINE LOGIFQ(STRING,LABEL,JUMP,IER) INCLUDE 'CMBLOCK.INC' INTEGER :: RHEXP CHARACTER(LEN=*) :: STRING,LABEL CHARACTER(LEN=80) :: ST CHARACTER(LEN=2) :: COMP(6) LOGICAL :: JUMP,BOOL(6,3) CHARACTER(LEN=1) :: NULL DATA BOOL/.FALSE.,.FALSE.,.TRUE., .TRUE., .FALSE.,.TRUE., 1 .TRUE., .TRUE., .TRUE., .FALSE.,.FALSE.,.FALSE., 2 .FALSE.,.TRUE., .FALSE.,.TRUE., .TRUE., .FALSE./ DATA COMP/'EQ', 'GE', 'LE', 'NE', 'GT', 'LT'/ C IEVAL WILL BE SWITCHED ON IF EXPRESSION FOUND IN 3RD POSITION IEVAL = 0 IND = 0 NULL = CHAR(0) C SET NO ERROR FLAG IER = 0 C REMOVE BLANKS FROM INPUT STRING, PUT OUTPUT IN ST CALL SHRINKQ(STRING,80,ST,MAXCH) C REMOVE ANY COMMENT FROM INPUT STRING ISEMICOL = INDEX(ST,';') IF (ISEMICOL .GT. 0) MAXCH = ISEMICOL - 1 C LOOK FOR ( NLP = INDEX(ST(:MAXCH),'(') IF (NLP .LE. 0) THEN C NO ( FOUND, MAY BE PLAIN GOTO LB# ICHAR = INDEX(ST(1:MAXCH),'GOTOLB') IF (ICHAR .LE. 0) THEN C ERROR, NO 'GOTO' FOUND ICHAR = 1 IFL = 9 GOTO 900 ENDIF C COPY LABEL STRING LABEL(1:5) = ST(ICHAR+4:ICHAR+7) // NULL JUMP = .TRUE. RETURN ENDIF C ICHAR IS THE CURRENT POSITION IN ST ICHAR = NLP + 1 C LOOK FOR FIRST PERIOD DELIMITER NXSTR = 2 LHEXP = 0 NNP = 1 C COMPUTE NNP: BALANCE OF ( AND ) { = NO. OF ('S MINUS NO OF )'S} 25 IF (ST(ICHAR:ICHAR) .EQ. '.') GOTO 26 IF (ST(ICHAR:ICHAR) .EQ. '(') NNP = NNP + 1 IF (ST(ICHAR:ICHAR) .EQ. ')') NNP = NNP - 1 ICHAR = ICHAR + 1 IFL = 2 IF (ICHAR .GT. MAXCH) GOTO 900 LHEXP = LHEXP + 1 GOTO 25 C PERIOD FOUND (PART OF .LOGICAL. EXPRESSION) 26 IFL = 3 IF (LHEXP .EQ. 0) GOTO 900 C EVALUATE LHEXP CALL EXPRQ(ST(NLP+1:),LHEXP,F1,IFLAG) IFL = 4 IF (IFLAG .NE. 0) GOTO 900 C ICHAR NOW POINTS TO FIRST PERIOD DO IFUNC = 1,6 IF (ST(ICHAR+1:ICHAR+2) .EQ. COMP(IFUNC)(1:2)) GOTO 60 ENDDO C ERROR, LOGICAL COMPARATOR NOT IDENTIFABLE IFL = 5 GOTO 900 C LOGICAL COMPARATOR IDENTIFIED 60 ICHAR = ICHAR + 4 NRHP = ICHAR C FIND RIGHT HAND EXPRESSION RHEXP = 0 61 IF (ST(ICHAR:ICHAR) .EQ. '(') NNP = NNP + 1 IF (ST(ICHAR:ICHAR) .EQ. ')') NNP = NNP - 1 IF (NNP .EQ. 0 .AND. ST(ICHAR:ICHAR) .EQ.')') GOTO 64 ICHAR = ICHAR+1 IFL = 6 IF (ICHAR .GT. MAXCH) GOTO 900 RHEXP = RHEXP+1 GOTO 61 64 IFL = 7 IF (RHEXP .EQ. 0) GOTO 900 N3 = ICHAR C EVALUATE RHEXP CALL EXPRQ(ST(NRHP:NRHP+RHEXP-1),RHEXP,F2,IFLAG) IFL = 8 IF (IFLAG .NE. 0) GOTO 900 C ICHAR NOW POINTS TO THE ) IGO = INDEX(ST(ICHAR+1:MAXCH),'GO') IF (IGO .LE. 0) THEN C NO 'GOTO' ENCOUNTERED, DOES IT HAVE 'THEN' ITHEN = INDEX(ST(ICHAR+1:MAXCH),'THEN') IEXIT = INDEX(ST(ICHAR+1:MAXCH),'EXIT') ICYCLE = INDEX(ST(ICHAR+1:MAXCH),'CYCLE') IF (ITHEN .GT. 0) THEN C HAS A 'THEN' INSTEAD OF A GOTO LABEL LABEL(1:5) = 'ELSE' // NULL ELSEIF (IEXIT .GT. 0) THEN C HAS A 'EXIT' , MAY WANT TO FIND ENDDO LABEL(1:5) = 'ENDDO' ELSEIF (ICYCLE .GT. 0) THEN C HAS A 'CYCLE', MAY WANT TO FIND ENDDO LABEL(1:5) = 'CYCLE' ELSE C NO 'THEN' SO SUBMIT TO EXPRESSION EVALUATOR LABEL(1:1) = ' ' NSTART = ICHAR+1 IEVAL = 1 ENDIF ELSE C SEARCH FOR "LB#" ILB = INDEX(ST,'GOTOLB') IF (ILB .LE. 0) THEN C ERROR, NO 'GOTOLB#' FOUND IFL = 9 GOTO 900 ENDIF C ICHAR NOW POINTS TO THE LB# STRING ICHAR = ILB + 4 C CHARACTERS "LB" FOUND. COPY LABEL STRING LABEL(1:5) = ST(ICHAR:ICHAR+3) // NULL ENDIF C APPLY COMPARATION COMPUTATION. IF (F1 .LT. F2) THEN ITAB = 1 ELSEIF (F1 .EQ. F2) THEN ITAB = 2 ELSE ITAB = 3 ENDIF C SET JUMP JUMP = BOOL(IFUNC,ITAB) C LOGICAL VALUE NEGATED FOR IF...THEN JUMP IF (LABEL(1:4) .EQ. 'ELSE') JUMP = .NOT. JUMP IF ((LABEL(1:5) .EQ. 'ENDDO' .OR. & LABEL(1:5) .EQ. 'CYCLE') .AND. (.NOT. JUMP)) THEN C 'IF' FAILED SO JUST CONTINUE WITH OPERATION STREAM LABEL = ' ' RETURN ENDIF IF (IEVAL .EQ. 0) RETURN IF (.NOT. JUMP) RETURN C EVALUATE REGISTER EXPRESSION CALL ARASQ(ST(N3+1:N3+MAXCH-NRHP),MAXCH-NRHP,IER) IF (IER .NE. 0) THEN WRITE(NOUT,904) ST(N3+1:N3+MAXCH-NRHP) 904 FORMAT(' *** ERROR EVALUATING: ',A) CALL ERRT(100,'LOGIFQ',NE) ENDIF RETURN C ERROR HANDLER 900 WRITE(NOUT,901) ST(ICHAR:MAXCH) 901 FORMAT(' *** IF STATEMENT SYNTAX ERROR STARTING AT: ',A) CALL ERRT(100,'LOGIFQ',NE) IER = 1 RETURN END