C++********************************************************************* C C FINDLBQ.F -- ADAPTED FOR CHAR. AUG 89 ArDean Leith C MERGED WITH SEARCHQ STUFF SEPT 97 ArDean Leith C ADDED IFLEVEL DEC. 97 ArDean Leith C INCORE PROCS JAN 01 ArDean Leith C LUNDONOW FEB 01 ArDean Leith C LNBLNKN MAY 04 ArDean Leith C DOC INSIDE LOOP BUG JUL 07 ArDean Leith C C ********************************************************************** C=* FROM: SPIDER - MODULAR IMAGE PROCESSING SYSTEM. AUTHOR: J.FRANK * C=* Copyright (C) 1985-2007 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 FINDLBQ(WANTLABEL,IDO,DOLABEL,INTHELOOP,IFLEVEL,IRTFLG) C C PURPOSE: SEARCHES FOR LB*, ELSE, OR ENDIF IN SPIDER INCOMING C OPERATIONS. C C PARAMETERS: C WANTLABEL LABEL WE ARE SEARCHING FOR (SENT) C CAN BE LB#, ELSE, ENDIF, EXIT C NLOOPT INSIDE DO-LOOP NOW IF > 0 (SENT) C DOLABEL CURRENT DO-LOOP LABEL (SENT) C INTHELOOP T, IF CURRENT DO-LOOP LABEL IS NOT PASSED (RET.) C F, IF PASS CURRENT DO-LOOP LABEL - MUST POP C DO-LOOP STACK IN DRIVER C IFLEVEL IF CLAUSE NESTING LEVEL (SENT & RET.) C IRTFLG ERROR NUMBER ZERO IS NORMAL (RET.) C C--******************************************************************* SUBROUTINE FINDLBQ(WANTLABEL,NLOOPT,DOLABEL,INTHELOOP, & IFLEVEL,IRTFLG) INCLUDE 'CMBLOCK.INC' COMMON /LUNDOECHO/ LUNDONOW CHARACTER *(*) WANTLABEL CHARACTER *80 ANSW LOGICAL KEEPGO INTEGER DOLABEL LOGICAL INTHELOOP #ifdef USE_MPI INCLUDE 'mpif.h' ICOMM = MPI_COMM_WORLD CALL MPI_COMM_RANK(ICOMM, MYPID, IERR) #else MYPID = -1 #endif INTHELOOP = .TRUE. KEEPGO = .TRUE. NEEDEND = 0 NEEDENDO = 1 C KEEP READING AND DISCARDING LINES FROM INPUT AS NEEDED DO WHILE (KEEPGO) ANSW(4:4) = ' ' C INCREMENT BATCH COUNTER 10 IBCNT = IBCNT + 1 IF (COPT .EQ. 'B') THEN C READ FROM CURRENT STORED PROCEDURE LINE IBCNT CALL PROC_GETPLINE(IBCNT,0,ANSW,NCHAR,IOS) ELSE C READ FROM FILE OPENED ON NIN (FOR INTERACTIVE LOOP) READ(NIN,80,IOSTAT=IOS) ANSW 80 FORMAT(A) NCHAR = LNBLNKN(ANSW) IF (LUNDONOW .GT. 0) THEN C MUST COPY INPUT LINE TO CURRENT INTERACTIVE DO-LOOP FILE WRITE(LUNDONOW,*) ANSW(1:NCHAR) ENDIF ENDIF IF (IOS .NE. 0) THEN WRITE(NOUT,91) WANTLABEL 91 FORMAT(' *** GOTO DESTINATION NEVER FOUND: ',A) CALL ERRT(100,'FINDLBQ',NE) IRTFLG = 1 RETURN ENDIF C REMOVE BLANKS FROM INPUT STRING CALL SHRINKQ(ANSW,80,ANSW,NCHAR) C IGNORE ANY COMMENTS AT END OF INPUT STRING ISEMICOL = INDEX(ANSW(1:NCHAR),';') IF (ISEMICOL .GT. 0) THEN ANSW(ISEMICOL:NCHAR) = CHAR(0) NCHAR = ISEMICOL - 1 ENDIF IF (NCHAR .LE. 0) GOTO 777 C CONVERT INPUT STRING TO ALL UPPER CASE CALL SSUPCAS(ANSW(1:NCHAR)) C SEE IF INPUT LINE CONTAINS 'THEN' IIFTHEN = INDEX(ANSW(1:NCHAR),'THEN') C FIND LAST NON-BLANK IN WANTLABEL LENLB = LNBLNKN(WANTLABEL) C FIND LAST NON-BLANK IN ANSW LENANSW = LNBLNKN(ANSW) LENT = INDEX(ANSW,CHAR(0)) - 1 IF (LENT .GT. 0) LENANSW = MIN(LENANSW,LENT) C -------------------------------------- SEARCHING FOR "ENDDO" IF (ANSW(1:2) .EQ. 'DO' .AND. & ANSW(3:4) .NE. 'LB' .AND. & ANSW(3:3) .NE. 'C' .AND. & WANTLABEL(:LENLB) .EQ. 'ENDDO') THEN C HUNTING FOR 'ENDDO' AND FOUND NESTED 'DO' NEEDENDO = NEEDENDO + 1 ELSEIF (ANSW(1:5) .EQ. 'ENDDO' .AND. & WANTLABEL(:LENLB) .EQ. 'ENDDO') THEN C HUNTING FOR 'ENDDO' AND FOUND IT NEEDENDO = NEEDENDO - 1 IF (NEEDENDO .LE. 0) KEEPGO = .FALSE. C ----------------------------------------- SEARCHING FOR "LB" ELSEIF (ANSW(1:2) .EQ. 'LB' .AND. & ANSW(:LENANSW) .EQ. WANTLABEL(:LENLB)) THEN C HUNTING FOR 'LB??' AND FOUND IT, HALT INPUT KEEPGO = .FALSE. IFLEVEL = IFLEVEL + NEEDEND IF (NEEDEND .GT. 0) THEN WRITE(NOUT,*)' WARNING: JUMP INTO "IF" CLAUSE' ENDIF ELSEIF (WANTLABEL(1:2) .EQ. 'LB' .AND. & ANSW(1:2) .EQ. 'IF' .AND. & IIFTHEN .GT. 5 ) THEN C HUNTING FOR 'LB..' AND FOUND A NEW "IF...THEN" CLAUSE NEEDEND = NEEDEND + 1 ELSEIF (WANTLABEL(1:2) .EQ. 'LB' .AND. & ANSW(1:5) .EQ. 'ENDIF') THEN C HUNTING FOR 'LB..' AND FOUND A 'END IF' NEEDEND = NEEDEND - 1 C --------------------------------------- SEARCHING FOR "ELSE" ELSEIF (WANTLABEL .EQ. 'ELSE' .AND. & ANSW(1:6) .EQ. 'ELSEIF') THEN C HUNTING FOR 'ELSE' AND FOUND 'ELSEIF' C IF NOT A NESTED ELSE, RETURN TO CALLER IF (NEEDEND .LE. 0) THEN KEEPGO = .FALSE. C DECREMENT BATCH COUNTER TO RE-READ THIS LINE IBCNT = IBCNT - 1 ENDIF ELSEIF (WANTLABEL .EQ. 'ELSE' .AND. & ANSW(1:4) .EQ. 'ELSE') THEN C HUNTING FOR 'ELSE' AND FOUND IT C IF NOT A NESTED ELSE, RETURN TO CALLER IF (NEEDEND .LE. 0) KEEPGO = .FALSE. ELSEIF (WANTLABEL .EQ. 'ELSE' .AND. & ANSW(1:5) .EQ. 'ENDIF') THEN C HUNTING FOR 'ELSE' AND FOUND ENDIF C IF NOT A NESTED ENDIF, RETURN TO CALLER IF (NEEDEND .LE. 0) THEN IFLEVEL = IFLEVEL - 1 KEEPGO = .FALSE. ENDIF C IF NESTED ENDIF KEEP READING INPUT NEEDEND = NEEDEND - 1 ELSEIF (WANTLABEL .EQ. 'ELSE' .AND. & ANSW(1:2) .EQ. 'IF' .AND. & IIFTHEN .GT. 5 ) THEN C HUNTING FOR 'ELSE' AND FOUND IF...THEN C THIS IS A NESTED IF, KEEP READING INPUT NEEDEND = NEEDEND + 1 C -------------------------------------- SEARCHING FOR "ENDIF" ELSEIF (WANTLABEL .EQ. 'ENDIF' .AND. & ANSW(1:2) .EQ. 'IF' .AND. & IIFTHEN .GT. 5 ) THEN C HUNTING FOR 'ENDIF' AND FOUND A NESTED IF...THEN NEEDEND = NEEDEND + 1 ELSEIF (WANTLABEL .EQ. 'ENDIF' .AND. & ANSW(1:5) .EQ. 'ENDIF') THEN C HUNTING FOR 'ENDIF' AND FOUND ENDIF C IF NOT A NESTED ENDIF, RETURN TO CALLER IF (NEEDEND .LE. 0) THEN KEEPGO = .FALSE. IFLEVEL = IFLEVEL - 1 ENDIF C IF NESTED ENDIF KEEP READING INPUT NEEDEND = NEEDEND - 1 ENDIF C SET INTHELOOP IF WE PASS BY CURRENT DO-LOOP LABEL IF (KEEPGO .AND. NLOOPT .GT. 0 .AND. ANSW(1:2) .EQ. 'LB')THEN CALL GETLBNO(ANSW,LBNO,IRTFLG) IF (LBNO .EQ. DOLABEL) INTHELOOP = .FALSE. ENDIF 777 CONTINUE ENDDO C FOUND DESIRED LABEL OR ENDIF CAN RETURN NOW IRTFLG = 0 C SIMULATE ECHO OF OPERATION TO RESULTS FILE FCHAR = ANSW IF (MYPID .LE. 0) WRITE(NDAT,90) ANSW(1:NCHAR) 90 FORMAT(' .OPERATION:',5X,A) RETURN END