C++******************************************************************* C C CHKSTR.FOR ADAPTED FROM CHKSTR AUG 89 ArDean Leith C IGNORE COMMENT NOW AUG 99 ArDean Leith C GETNEXTTOKEN ACCEPTS TAB NOV 99 ARDEAN LEITH C SPLIT GETNEXTTOKEN TO FILE JAN 00 ARDEAN LEITH C 'RR' X? BINDING TIME BUG NOV 01 ARDEAN LEITH C [] REG SUPPORT NOV 05 ARDEAN LEITH C 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 CHKSTR(STRING,NCHAR,TYPE,NUML,FNUML,NMAX,INUM,IRTFLG) C C PURPOSE: EXTRACTS INTERGER OR REAL VALUES FROM STRING. C CAN SUBSTITUTE FOR REGISTER CONTENT OR RETURN C REGISTER NUMBER LISTING C PARAMETERS: C STRING INPUT STRING (SENT) C NCHAR # OF CHARACTERS IN INPUT STRING (SENT) C TYPE TYPE OF NUMBERS RETURNED (SENT) C I = INTEGER LIST OF REGISTER CONTENTS C R = FLOATING LIST C IT = REGISTER NUMBERS IN NUML C RE = FLOATING LIST OF REGISTER CONTENTS C AND INTEGER LIST OF REGISTER NUMBERS C C NUML INTEGER ARRAY, IF NEEDED (RET.) C FNUML REAL ARRAY, IF NEEDED (RET.) C NMAX SIZE OR NUML AND FNUML (SENT) C INUM # OF NUMBERS RETURNED IN NUML OR FNUML (RET.) C IRTFLG ERROR FLAG, =0 IF ALL O.K. (RET.) C C23456789012345678901234567890123456789012345678901234567890123456789012 C--********************************************************************* SUBROUTINE CHKSTR(STRING,NCHAR,TYPE,NUML,FNUML,NMAX,INUM,IRTFLG) INCLUDE 'CMBLOCK.INC' INCLUDE 'CMLIMIT.INC' CHARACTER(LEN=*) :: STRING,TYPE INTEGER :: NUML(NMAX) REAL :: FNUML(NMAX) LOGICAL :: RFLAG INUM = 0 IRTFLG = 1 IFIRST = 1 IF (TYPE .EQ. 'IRRE' .OR. TYPE .EQ. 'IR') THEN C OBSOLETE WRITE(NOUT,*) ' *** PGM ERROR OBSOLETE TYPE: ',TYPE, & ' IN CHKSTR' CALL ERRT(101,'PGM ERROR OBSOLETE TYPE IN CHKSTR',NE) RETURN ENDIF DO c GET TOKEN (CHAR. STRING DELIMITED BY A ", ()") FROM STRING CALL GETNEXTTOKEN(STRING(1:NCHAR),IFIRST,IGO,IEND) IF (IGO .LE. 0) THEN C ALL TOKENS FROM STRING HAVE BEEN EVALUATED IRTFLG = 0 RETURN ENDIF C TOKEN RETURNED RFLAG = .FALSE. IF (STRING(IGO:IGO) .EQ. '[')THEN C TOKEN STARTS WITH '[', SO IS A REGISTER REFERENCE IF (IGO .GE. NCHAR) RETURN RFLAG = .TRUE. ENDIF INUM = INUM + 1 IF (INUM .GT. NMAX) THEN C PREVENT NUML OVERFLOW!! WRITE(NOUT,91) NMAX 91 FORMAT('*** ONLY: ',I6, & ' VALUES RETURNED BY CHKSTR TO PREVENT OVERFLOW'/) RETURN ENDIF IF (RFLAG) THEN C GET REGISTER VALUE & NUMBER FROM TOKEN CALL REG_GET_VAR(0,STRING(IGO:IEND),.FALSE.,FVAL,IREG, & IEND,IRTFLG) IF (IRTFLG .NE. 0) RETURN IEND = IEND + IGO -1 IF (TYPE .EQ. 'R') THEN C RETURN FLOATING POINT IN FNUML FNUML(INUM) = FVAL ELSEIF (TYPE .EQ. 'RE') THEN C RETURN FLOATING POINT IN FNUML & IREG IN INUML FNUML(INUM) = FVAL NUML(INUM) = IREG ELSEIF (TYPE .EQ. 'I') THEN C EXTRACT FLOATING POINT AND RETURN AS INTEGER NUML(INUM) = FVAL ELSEIF (TYPE .EQ. 'IT') THEN C RETURN REGISTER NUMBERS IN NUML, (NOT REGISTER CONTENTS) C ACCEPTS [] INPUT AND RETURNS REGISTER NUMBER NUML(INUM) = IREG ENDIF ELSEIF (TYPE .EQ. 'I') THEN C EXTRACT INTEGER READ(STRING(IGO:IEND),*,IOSTAT=IERR) NUML(INUM) IF (IERR .NE. 0) THEN WRITE(NOUT,*) 'BAD INPUT STRING: ',STRING(IGO:IEND) RETURN ENDIF IF (IERR .NE. 0) RETURN ELSEIF (TYPE .EQ. 'R' .OR. TYPE .EQ. 'RE') THEN C EXTRACT REAL NUMBER READ(STRING(IGO:IEND),*,IOSTAT=IERR) FNUML(INUM) IF (IERR .NE. 0) THEN WRITE(NOUT,*) 'BAD INPUT STRING: ',STRING(IGO:IEND) RETURN c WRITE(NOUT,*) 'NO. CHARACTERS IN STRING: ',NCHAR c WRITE(NOUT,*) 'IFIRST: ',IFIRST,' INUM: ',INUM, c & ' IGO: ',IGO,' IEND: ',IEND ENDIF IF (TYPE .EQ. 'RE') NUML(INUM) = 0 ENDIF IFIRST = IEND + 1 IF (IFIRST .GT. NCHAR) EXIT ENDDO 79 IRTFLG = 0 RETURN END