* This file contains all the routines needed _only_ by INKEYS so that they * can be linkedited together. * * 10-Oct-1989 DFB IBM-specific code (calls to ALLDD and DEALL) removed. * 2-Nov-1989 DFB Nord-specific options ($IMPLICIT OFF/ON, $INCLUDE) put in. * 18-Apr-1990 DFB Unix version * 27-Feb-1991 DFB MAXREC calculation altered. * 19-Apr-1991 DFB Remove use of ASSIGN statement by using subroutines. * 2-May-1991 DFB Use status='new' when saving parfiles. SUBROUTINE INKEYS(MODE,PARFILE) * =============================== IMPLICIT UNDEFINED (A-Z) INTEGER MODE CHARACTER*(*) PARFILE MODE=2 CALL KEYIN(MODE,5,6,PARFILE) END SUBROUTINE KEYIN (MODE,IN,PR,PROG) C----------------------------------------------------------------------- C Free-format keyed input C C T.J.Pearson 1978 May 31 IBM 370 C Modified 1979 Jun 25 VAX-11 Fortran C ..... (updates removed - see original file) C Modified 1988 Sept 10 DFB - make into standard F77 C 10-Oct-1989 DFB IBM-specific code (calls to ALLDD and DEALL) removed. C 21-Apr-1990 DFB PARFILE option added C 17-Sep-1990 DFB Character array subscripts bug removed. Parameter file C extension now made system-independent through call to FILEXT C C Arguments: C MODE: integer variable: C (input) 1 = turn on reflection, 0 = turn off C 2 = interactive mode (prompts for input, C no reflection, no limit on errors) C (output) 1 = eof found, 0 = endmrk found C IN: input unit number C PR: printer unit number for reflection and messages C PROG: Name of calling program - used as default filename for ".par" file C----------------------------------------------------------------------- IMPLICIT UNDEFINED (A-Z) INTEGER MODE,IN,PR CHARACTER*(*) PROG INTEGER CHPWRD PARAMETER (CHPWRD=8) INCLUDE "keydefs.inc" C REAL*8 EXPRES,RESULT,CHTOR CHARACTER*8 WORD,BLANK8,UNSET,SHOW,SAVE,EOL,ENDMRK CHARACTER*1 REC(81),FCH,DELIM(3),BLANK,EQUALS,COMMA,ARROW,BRA, 1 KET,SQUOTE,DQUOTE,QUEST,TAB,EXCL,ATSIGN,NUMER(13), 2 SLASH INTEGER*4 CHTOI,COMPST,ERRCNT,P INTEGER INUNIT,LUNSAV,NEW,NK,IK,INDX,NK2,I,MAXREC,IP,II,LEN1 INTEGER IER,NW,I1,NLETS,J,STATUS LOGICAL REFLEC,DIALOG,SAVERF,SAVEDL,EQFND CHARACTER*64 TEXT PARAMETER(BLANK=' ',EQUALS='=',COMMA=',',ARROW='>') PARAMETER(BRA='(',KET=')',SQUOTE='''',DQUOTE='"') PARAMETER(QUEST='?',EXCL='!',ATSIGN='@',SLASH='/') PARAMETER(BLANK8=' ',UNSET='***UNSET',SHOW='SHOW',EOL='***EOL') PARAMETER(SAVE='SAVE',ENDMRK='/') DATA REC/81*' '/ DATA NUMER/'-','+','.','0','1','2','3','4','5','6','7', 6 '8','9'/ TAB=CHAR(5) C C Check i/o units C P = PR IF (P.LT.1 .OR. P.GT.99) P = 6 INUNIT = IN * treat wrong logical unit as EOF IF (IN.LT.0 .OR. IN.GT.99) GOTO 340 C REFLEC = MODE.EQ.1 DIALOG = MODE.EQ.2 FCH = BLANK ERRCNT = 0 MODE = 0 GOTO 102 100 IF(ENDMRK.EQ.EOL) GOTO 350 C - Read a brand-new record (come here after errors) 102 CONTINUE STATUS=0 CALL KRDREC(INUNIT,P,REFLEC,DIALOG,FCH,REC,MAXREC,STATUS) IF(STATUS.NE.0)GOTO 340 I=1 C C Look for next input word: it is either a comment, an C @-command, or a keyword. C 130 CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) GOTO 100 C C Comment: skip rest of line. C IF (REC(I).EQ.EXCL) GOTO 100 C C @-command: include file (VAX specific). If this facility C is not required, omit this IF clause. The file name is C in the character variable TEXT, and the unit is C obtained from the pool. C IF (REC(I).EQ.ATSIGN) THEN IER = 6 TEXT = ' ' I = I+1 CALL SKIPBL(REC,MAXREC,I) WRITE (TEXT,400) (REC(IP),IP=I,MAXREC) IF (TEXT.EQ.' ')TEXT=PROG STATUS=0 CALL FILEXT(TEXT,'par',STATUS) CALL GETLUN(NEW) OPEN (UNIT=NEW, FORM='FORMATTED', FILE=TEXT, 1 STATUS='OLD', ERR=330) INUNIT = NEW SAVEDL = DIALOG SAVERF = REFLEC REFLEC = REFLEC.OR.DIALOG DIALOG = .FALSE. FCH = ATSIGN GOTO 100 END IF C C Keyword: pack into WORD. C CALL KGETKEY(REC,I,WORD) C C Scan 'PARS' for 'WORD'; error if not found C (check first that 'WORD' is not 'ENDMRK' C or a special command-word) C IF (COMPST(WORD,ENDMRK,8,QUEST).EQ.0) THEN GOTO 350 ELSE IF (COMPST(WORD,SHOW,8,QUEST).EQ.0) THEN CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) THEN CALL KEYOUT(PARS,VALS,NPARS,P) ELSE CALL KGETKEY(REC,I,WORD) DO 500 NK=1,NPARS IF (COMPST(WORD,PARS(NK),8,QUEST).EQ.0) THEN NK2 = 1 505 IF(COMPST(WORD,PARS(NK+NK2),8,QUEST).NE.0 1 .AND. PARS(NK+NK2).NE.BLANK8)GOTO 507 NK2 = NK2+1 GOTO 505 507 CONTINUE CALL KEYOUT(PARS(NK),VALS(NK),NK2,P) GOTO 130 END IF 500 CONTINUE * error: unknown parameter IER = 4 GOTO 330 END IF GOTO 130 ELSE IF (COMPST(WORD,SAVE,8,QUEST).EQ.0) THEN * signal file-name error IER = 6 TEXT = ' ' I = I+1 CALL SKIPBL(REC,MAXREC,I) WRITE (TEXT,400) (REC(IP),IP=I,MAXREC) IF(TEXT.EQ.' ')TEXT=PROG STATUS=0 CALL FILEXT(TEXT,'par',STATUS) CALL GETLUN(LUNSAV) C - DFB mod - delete output file if it exists, so STATUS='NEW' always works CALL NEWFILE(TEXT) OPEN (UNIT=LUNSAV,FORM='FORMATTED', FILE=TEXT, 2 STATUS='NEW', ERR=330) CALL KEYOUT(PARS,VALS,NPARS,LUNSAV) INQUIRE (UNIT=LUNSAV,NAME=TEXT) WRITE (P,450) TEXT(1:LEN1(TEXT)) CLOSE (UNIT=LUNSAV) GOTO 100 END IF 156 DO 160 NK=1,NPARS IF(COMPST(WORD,PARS(NK),8,QUEST).EQ.0) GOTO 170 160 CONTINUE * error: unknown parameter IER=4 GOTO 330 C C Look for (subscript) to keyword C 170 EQFND = .FALSE. IF (REC(I).NE.BRA) GOTO 190 I=I+1 INDX=CHTOI(REC,MAXREC,I) * subscript error? IER=1 IF(REC(I).NE.KET) GOTO 330 I=I+1 IF (INDX.LT.1) GOTO 330 C C DFB fix - skip correct number of elements in the case of character C variables. C DO IK=1,INDX-1 185 NK=NK+1 IF (NK.GT.NPARS) GOTO 330 IF (PARS(NK).EQ.BLANK8) GOTO 185 IF (COMPST(WORD,PARS(NK),8,QUEST).NE.0) GOTO 330 END DO 180 CONTINUE C - too many VALS? IER = 2 IF (NK.GT.NPARS) GOTO 330 IF (COMPST(WORD,PARS(NK),8,QUEST).NE.0) GOTO 330 C C Look for value after optional '='. If no value C and no "=", assign value 0. C 190 CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) THEN VALS(NK) = 0D0 GOTO 100 END IF IF (REC(I).EQ.EQUALS) THEN I=I+1 EQFND = .TRUE. CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) THEN STATUS=0 CALL KRDREC(INUNIT,P,REFLEC,DIALOG,FCH,REC,MAXREC,STATUS) IF(STATUS.NE.0)GOTO 340 I=1 CALL SKIPBL(REC,MAXREC,I) END IF END IF C C If a bracket is found, read an expression. C IF (REC(I).EQ.BRA) GOTO 205 C C If an explicit quotation mark is found, read C a quoted string. C DELIM(1) = REC(I) DELIM(2) = REC(I) DELIM(3) = REC(I) IF (REC(I).EQ.SQUOTE .OR. REC(I).EQ.DQUOTE) GOTO 210 C C If the parameter requires a character value, C read an unquoted (blank-terminated) string. C IF ((NK.LT.NPARS).AND.(PARS(NK+1).EQ.BLANK8)) GOTO 202 C C If '+', '-', '.', or a digit is found, read a C numerical value. C DO 510 II=1,13 510 IF (REC(I).EQ.NUMER(II)) GOTO 201 C C Otherwise, read a string terminated by blank C or comma, but only if an equals sign was found. C IF (.NOT.EQFND) THEN VALS(NK) = 0D0 GOTO 260 END IF 202 I = I-1 DELIM(1) = BLANK DELIM(2) = COMMA DELIM(3) = TAB GOTO 210 C C Numeric value. C 201 RESULT=CHTOR(REC,MAXREC,I) IF (REC(I).EQ.BLANK .OR. REC(I).EQ.COMMA .OR. REC(I).EQ.EXCL 1 .OR. REC(I).EQ.TAB .OR. REC(I).EQ.SLASH) THEN VALS(NK) = RESULT GOTO 260 ELSE * bad numeric value IER = 8 GOTO 330 END IF C C Arithmetic expression C 205 RESULT=EXPRES(REC,MAXREC,I,IER) IF(IER.NE.0) GOTO 330 VALS(NK) = RESULT GOTO 260 C C Textual value - 'NW' words of 'CHPWRD' characters C 210 NW=1 VALS(NK)=C8TOR8(BLANK8) 220 IF(NK+NW.GT.NPARS) GOTO 230 IF(PARS(NK+NW).NE.BLANK8) GOTO 230 VALS(NK+NW)=C8TOR8(BLANK8) NW=NW+1 GOTO 220 230 I1=I+1 NLETS=0 240 I=I+1 IF(I.GT.MAXREC) GOTO 250 IF(REC(I).EQ.DELIM(1).OR.REC(I).EQ.DELIM(2).OR.REC(I).EQ. 1 DELIM(3)) GOTO 250 NLETS=NLETS+1 GOTO 240 250 CALL CNTOR8(REC(I1),VALS(NK),MIN0(CHPWRD*NW,NLETS)) IF (REC(I).NE.COMMA) I=I+1 NK=NK+NW-1 C C Look for another value, if allowed C 260 CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) GOTO 100 IF (REC(I).NE.COMMA) GOTO 130 I = I+1 CALL SKIPBL(REC,MAXREC,I) IF (I.GT.MAXREC) THEN STATUS=0 CALL KRDREC(INUNIT,P,REFLEC,DIALOG,FCH,REC,MAXREC,STATUS) IF(STATUS.NE.0)GOTO 340 I=1 END IF NK = NK+1 GOTO 180 C C---------------------------------------------------------------------- C Error report C---------------------------------------------------------------------- C 330 IF(.NOT.(REFLEC.OR.DIALOG)) WRITE(P,410) FCH,(REC(J),J=1,MAXREC) WRITE(P,410) BLANK,(ARROW,J=1,I) IF(IER.EQ.1) WRITE(P,440) 'in subscript of ',WORD IF(IER.EQ.2) WRITE(P,440) 'Too many VALS for ',WORD IF(IER.EQ.4) WRITE(P,440) 'Unknown parameter: ',WORD IF(IER.EQ.6) WRITE(P,440) 'Bad file name: ', 1 TEXT(1:LEN1(TEXT)) IF(IER.EQ.8) WRITE(P,440) 'Not a valid number' IF(IER.EQ.11) WRITE(P,440) 'Too many parentheses' IF(IER.EQ.12) WRITE(P,440) 'Expecting ")"' IF(IER.EQ.13) WRITE(P,440) 'Value expected after operator' IF(IER.EQ.14) WRITE(P,440) 'Attempt to divide by zero' IF(DIALOG) GOTO 102 ERRCNT=ERRCNT+1 IF(ERRCNT.LT.10) GOTO 102 C C---------------------------------------------------------------------- C EOF or 'ENDMRK' found C---------------------------------------------------------------------- C If this is the end of a file included with an C @-command, revert to original file; otherwise C check that VALS have been assigned to all C compulsory parameters (default value '***UNSET') C 340 IF (INUNIT.NE.IN) THEN CLOSE (UNIT=INUNIT) INUNIT = IN REFLEC = SAVERF DIALOG = SAVEDL ERRCNT = 0 FCH = BLANK GOTO 100 END IF MODE = 1 350 IF (ERRCNT.GT.0) CALL ERROR('in input parameters') DO 520 NK=1,NPARS 520 IF (R8TOC8(VALS(NK)).EQ.UNSET) GOTO 380 RETURN 380 DO 530 NK=1,NPARS IF (R8TOC8(VALS(NK)).EQ.UNSET) 1 WRITE (P,440) 'Value needed for ',PARS(NK) 530 CONTINUE IF (DIALOG.AND.MODE.NE.1) GOTO 102 CALL ERROR('in input parameters.') C C---------------------------------------------------------------------- C Format statements. C---------------------------------------------------------------------- 400 FORMAT (120A1) 410 FORMAT (1X,A1,1X,120A1) 440 FORMAT (' +++ERROR+++ ',A,A) 450 FORMAT (' Saved: ',A) C END SUBROUTINE KRDREC(INUNIT,P,REFLEC,DIALOG,FCH,REC,MAXREC,STATUS) C---------------------------------------------------------------------- C Internal routine to read a record C (DFB mod - no symbol substitution) C---------------------------------------------------------------------- IMPLICIT NONE INTEGER INUNIT,P,MAXREC,STATUS LOGICAL REFLEC,DIALOG CHARACTER*1 REC(*),FCH C - Local variables INTEGER I CHARACTER*80 INREC C - External functions INTEGER LEN1 IF(STATUS.NE.0)RETURN IF (INUNIT.EQ.0) THEN STATUS=-1 RETURN ENDIF IF (DIALOG) WRITE (P,1112)' *' 1112 FORMAT(A,$) READ (INUNIT,'(A80)',END=99) INREC MAXREC=MAX(1,LEN1(INREC)) IF (REFLEC) WRITE(P,'(1X,A1,1X,A)') FCH,INREC(1:MAXREC) READ (INREC,'(80A1)') (REC(I),I=1,MAXREC) REC(MAXREC+1) = ' ' RETURN C - Come here on EOF 99 CONTINUE STATUS=-1 END SUBROUTINE KGETKEY(REC,I,WORD) C---------------------------------------------------------------------- C Internal routine to find a keyword. C---------------------------------------------------------------------- IMPLICIT NONE INTEGER I CHARACTER*1 REC(*),WORD*(*) C - Local variables INTEGER I1,NLETS CHARACTER*1 BLANK,EQUALS,COMMA,ARROW,BRA, 1 KET,SQUOTE,DQUOTE,QUEST,TAB,EXCL,ATSIGN, 2 SLASH PARAMETER(BLANK=' ',EQUALS='=',COMMA=',',ARROW='>') PARAMETER(BRA='(',KET=')',SQUOTE='''',DQUOTE='"') PARAMETER(QUEST='?',EXCL='!',ATSIGN='@',SLASH='/') TAB=CHAR(5) C - Get token I1 = I NLETS = 1 8100 I = I+1 IF(REC(I).EQ.BLANK .OR. REC(I).EQ.EQUALS .OR. REC(I).EQ.EXCL 1 .OR. REC(I).EQ.BRA .OR. REC(I).EQ.TAB) GOTO 8200 NLETS = NLETS+1 GOTO 8100 C - Copy and blank-pad 8200 WORD = ' ' CALL CHCOPY(REC(I1),WORD,MIN0(LEN(WORD),NLETS)) END SUBROUTINE KEYPUT(TEXT,P) C----------------------------------------------------------------------- C Write TEXT to unit P, filling lines if possible. C----------------------------------------------------------------------- CHARACTER*(*) TEXT CHARACTER*78 BUFFER INTEGER P SAVE BUFFER,LB DATA LB/0/ C IF (TEXT.EQ.'***END') THEN IF (LB.GT.0) WRITE (P,1000) BUFFER(1:LB) LB = 0 RETURN END IF IF (LB+LEN1(TEXT).GT.LEN(BUFFER)) THEN WRITE (P,1000) BUFFER(1:LB) LB = 0 END IF BUFFER(LB+1:) = TEXT LB = LB+LEN1(TEXT) RETURN 1000 FORMAT(2X,A) END LOGICAL FUNCTION KEYCHK(WORD,NC) C----------------------------------------------------------------------- C Test whether value could be a character string C - It is considered to be character rather than C numeric unless one or more bytes are ASCII control C characters (0-31 decimal). Of course this doesn't C always work as any character string is also a C valid number. * IBM VERSION: Check if character lt space (works in both ASCII and EBDIC) * NORD VERSION: Need to use INTEGER*1 * UNIX VERSION: back to CHARACTER*1 C----------------------------------------------------------------------- CHARACTER*1 WORD(NC) C KEYCHK=.FALSE. DO 10 I=1,NC 10 IF(WORD(I).LT.' ') RETURN KEYCHK=.TRUE. RETURN END FUNCTION EXPRES(S,IMAX,I,ERROR) C----------------------------------------------------------------------- C Evaluate an arithmetic expression. Input array S C contains the character string in A1 format; expression C is evaluated starting at S(I) and ending at S(IMAX) C or at a character which cannot be part of the C expression. The value of I returned points to the C invalid character or is IMAX+1. This is a pseudo- C recursive procedure: the "stack level" is LEVEL. C Dimensions are sufficient for 9 nested parentheses. * IBM VERSION: S is character*1 C C ERROR = 0 : success C 11 : too many parentheses C 12 : expecting ')' C 13 : missing value after operator C 14 : divide by zero C----------------------------------------------------------------------- CHARACTER*1 S,OP,PLUS,MINUS,STAR,SLASH,BRA,KET INTEGER*4 SIGN,ERROR REAL*8 EXPRES,RESULT,TERM,FACTOR,CHTOR DIMENSION S(IMAX) DIMENSION RESULT(10),TERM(10),FACTOR(10),OP(10),SIGN(10) PARAMETER(PLUS='+',MINUS='-',STAR='*',SLASH='/',BRA='(',KET=')') C ERROR=0 LEVEL=1 C C Evaluate 'expression' 100 RESULT(LEVEL)=0.0 110 SIGN(LEVEL)=+1 IF(S(I).NE.PLUS) GOTO 120 I=I+1 120 IF(S(I).NE.MINUS) GOTO 130 I=I+1 SIGN(LEVEL)=-1 130 CONTINUE C C Evaluate 'term' TERM(LEVEL)=1.0 OP(LEVEL)=STAR 200 CONTINUE C C Evaluate 'factor' C Parenthesized expression = 'expression' at next level IF(S(I).NE.BRA) GOTO 330 I=I+1 LEVEL=LEVEL+1 IF(LEVEL.LE.10) GOTO 100 ERROR=11 RETURN 310 FACTOR(LEVEL-1)=RESULT(LEVEL) LEVEL=LEVEL-1 IF(S(I).EQ.KET) GOTO 320 ERROR=12 RETURN 320 I=I+1 GOTO 340 330 IP=I FACTOR(LEVEL)=CHTOR(S,IMAX,I) IF(I.NE.IP) GOTO 340 ERROR=13 RETURN 340 CONTINUE C End 'factor' C IF(OP(LEVEL).EQ.STAR) THEN TERM(LEVEL)=TERM(LEVEL)*FACTOR(LEVEL) ELSE IF(OP(LEVEL).EQ.SLASH) THEN IF(FACTOR(LEVEL).EQ.0.0) THEN ERROR=14 RETURN ELSE TERM(LEVEL)=TERM(LEVEL)/FACTOR(LEVEL) END IF END IF IF(S(I).NE.SLASH.AND.S(I).NE.STAR) GOTO 210 OP(LEVEL)=S(I) I=I+1 GOTO 200 210 CONTINUE C End 'term' C RESULT(LEVEL)=RESULT(LEVEL)+SIGN(LEVEL)*TERM(LEVEL) IF(S(I).EQ.PLUS.OR.S(I).EQ.MINUS) GOTO 110 C End 'expression' C IF(LEVEL.GT.1) GOTO 310 EXPRES=RESULT(LEVEL) RETURN END SUBROUTINE KEYOUT(PARS,VALS,N,P) C----------------------------------------------------------------------- C SAVE/SHOW routine for KEYIN C - list parameters and VALS to unit P C----------------------------------------------------------------------- INTEGER N,P,I,J,INBLK REAL*8 VALS(N) CHARACTER*8 PARS(N) CHARACTER*8 BLANK8 LOGICAL KEYCHK CHARACTER*1 CONTIN CHARACTER*10 WORD CHARACTER*80 TEXT,TEXT2 PARAMETER(BLANK8=' ') C I = 1 CONTIN = ' ' 100 IF (I.GT.N) RETURN WRITE (WORD,'(A8)') PARS(I) IF (CONTIN.EQ.',') WORD = ' ' J = 1 ****WHILE 200 IF((I+J.GT.N .OR. PARS(I+J).NE.BLANK8))GOTO 210 J = J+1 GOTO 200 210 CONTINUE ****END WHILE WRITE (TEXT,'(10A8)') (VALS(K),K=I,I+MIN(J-1,9)) CONTIN = ' ' IF (I.LT.N .AND. PARS(I).EQ.PARS(I+J)) CONTIN = ',' IF (WORD.NE.' ') CALL KEYPUT(WORD//' =',P) IF (J.GT.1 .OR. KEYCHK(VALS(I),8)) THEN TEXT2 = '"'//TEXT(1:LEN1(TEXT))//'"' TEXT=TEXT2 ELSE IF (DABS(VALS(I)).LT.1D7) THEN IF (DMOD(VALS(I),1D0).EQ.0D0) THEN IVAL = IDINT(VALS(I)) WRITE (TEXT,620) IVAL ELSE WRITE(TEXT,630) VALS(I) END IF ELSE WRITE (TEXT,630) VALS(I) END IF ****WHILE INBLK=1 300 IF(.NOT.(TEXT(INBLK:INBLK).EQ.' '))GOTO 301 INBLK=INBLK+1 GOTO 300 301 CONTINUE ****END WHILE TEXT2=TEXT(INBLK:) IF (CONTIN.EQ.',') THEN TEXT = TEXT2(1:LEN1(TEXT2))//',' ELSE TEXT=TEXT2 ENDIF CALL KEYPUT(' '//TEXT(1:LEN1(TEXT)),P) IF (CONTIN.NE.',') CALL KEYPUT('***END',P) I = I+J GOTO 100 C 620 FORMAT(I9) 630 FORMAT(1PG25.16) C END FUNCTION CHTOI(S,N,I) C C TJP 1977 DECEMBER 4 CIT 370/158 C MODIFIED 1979 FEB 6 VAX/VMS FORTRAN 4 C C EVALUATE INTEGER AT S(I); INCREMENT I * IBM VERSION: s is character*1 C INTEGER CHTOI,N,I CHARACTER*1 S(N),DIGITS(10) DATA DIGITS/'0','1','2','3','4','5','6','7','8','9'/ C CHTOI=0 10 IF(I.GT.N) RETURN DO 20 K=1,10 IF(S(I).EQ.DIGITS(K)) GOTO 30 20 CONTINUE RETURN 30 CHTOI=CHTOI*10+K-1 I=I+1 GOTO 10 END C======================================================================= FUNCTION CHTOR(S,N,I) C C T.J.PEARSON 1978 MAY 11 C MODIFIED 1979 FEB 6 VAX/VMS FORTRAN 4 C C EVALUATE NUMBER AT S(I); INCREMENT I * IBM VERSION: s is character*1 C REAL*8 CHTOR,CHTOD,FRACTN INTEGER CHTOI,SIGN INTEGER N,I CHARACTER*1 S(N),COLON,PLUS,MINUS,POINT,E,ELC DATA COLON/':'/,PLUS/'+'/,MINUS/'-'/,POINT/'.'/, 1 E/'E'/,ELC/'e'/ C CHTOR=0D0 IF(I.GT.N) RETURN SIGN=+1 IF(S(I).NE.MINUS) GOTO 130 I=I+1 SIGN=-1 CALL SKIPBL(S,N,I) GOTO 140 130 IF(S(I).NE.PLUS) GOTO 140 I=I+1 CALL SKIPBL(S,N,I) 140 ISTART=I 150 CHTOR=CHTOD(S,N,I)*SIGN + CHTOR*60D0 IF(I.GT.N) RETURN IF(S(I).NE.COLON) GOTO 160 I=I+1 GOTO 150 C C LOOK FOR FRACTIONAL PART, IF ANY C 160 IF(S(I).NE.POINT) GOTO 170 J=I+1 FRACTN=CHTOD(S,N,J)*SIGN CHTOR=CHTOR + FRACTN*10D0**(I-J+1) I=J IF(I.GT.N) RETURN C C Look for exponent, if any; an exponent may not stand C alone C 170 IF(.NOT.(S(I).EQ.E.OR.S(I).EQ.ELC) .OR. I.EQ.ISTART) GOTO 270 I=I+1 IF(I.GT.N) RETURN SIGN=+1 IF(S(I).NE.MINUS) GOTO 180 I=I+1 SIGN=-1 GOTO 190 180 IF(S(I).NE.PLUS) GOTO 190 I=I+1 190 CHTOR=CHTOR * 10D0**(SIGN*CHTOI(S,N,I)) 270 RETURN END C======================================================================= FUNCTION CHTOD(S,N,I) C C T.J. PEARSON 1979 JUN 4 VAX/VMS FORTRAN 4 C C EVALUATE INTEGER AT S(I); INCREMENT I C RETURN AS REAL*8 * IBM VERSION: s is character*1 C INTEGER N,I CHARACTER*1 S(N),DIGITS(10) REAL*8 CHTOD DATA DIGITS/'0','1','2','3','4','5','6','7','8','9'/ C CHTOD=0D0 10 IF(I.GT.N) RETURN DO 20 K=1,10 IF(S(I).EQ.DIGITS(K)) GOTO 30 20 CONTINUE RETURN 30 CHTOD=CHTOD*10D0 + (K-1) I=I+1 GOTO 10 END C======================================================================= SUBROUTINE SKIPBL(S,N,I) C C T.J.PEARSON 1978 MAY 11 C MODIFIED 1979 FEB 6 (VAX/VMS FORTRAN 4) * IBM VERSION: s is character*1 C C SKIP BLANKS FROM S(I); INCREMENT I C INTEGER N,I CHARACTER*1 S(N),BLANK,TAB PARAMETER(BLANK=' ') C TAB=CHAR(5) 10 IF(I.GT.N) RETURN IF(S(I).NE.BLANK.AND.S(I).NE.TAB) RETURN I=I+1 GOTO 10 END INTEGER FUNCTION COMPST (S1,S2,N,WILD) C----------------------------------------------------------------------- C Compare character strings; used by KEYIN. The input character strings C are stored in BYTE arrays in format A1. A wild character in C either string matches any character in the other string. A lower-case C letter in string 2 matches the correpsonding upper or lower case C letter or a space in string 1. A lower-case letter in string 1 matches C the correpsonding upper or lower case letter in string 2. C C Returns: C INTEGER COMPST : position of first mismatch, or 0 if strings match. C C Arguments: C BYTE S1(N) : first input string (candidate string). C BYTE S2(N) : second input string (pattern string). C INTEGER N : number of characters in each string. C BYTE WILD : "wild character". C C History: C 1977 Dec 12 - CIT IBM 370/158 [TJP]. C 1979 Feb 6 - adapted for VAX/VMS Fortran 4+ [TJP]. C 1985 Feb 26 - add lower-case/space match [TJP]. * IBM VERSION: s1,s2,wild are character*1; code modified to be (almost) * independent of character collating sequence. C----------------------------------------------------------------------- IMPLICIT UNDEFINED (A-Z) INTEGER N, I, T1, T2 CHARACTER*1 S1(N), S2(N), WILD C DO 10 I=1,N T1 = ICHAR(S1(I)) T2 = ICHAR(S2(I)) IF (ICHAR('a').LE.T1 .AND. T1.LE.ICHAR('z')) : T1 = T1-ICHAR('a')+ICHAR('A') IF (ICHAR('a').LE.T2 .AND. T2.LE.ICHAR('z')) : T2 = T2-ICHAR('a')+ICHAR('A') IF (T1.EQ.T2) GOTO 10 IF (S1(I).EQ.WILD) GOTO 10 IF (S2(I).EQ.WILD) GOTO 10 T2=ICHAR(S2(I)) IF (ICHAR('a').LE.T2 .AND. : T2.LE.ICHAR('z') .AND. : S1(I).EQ.' ') GOTO 10 COMPST = I RETURN 10 CONTINUE COMPST = 0 RETURN END SUBROUTINE CHCOPY(IN,OUT,N) * ========================= INTEGER N,I CHARACTER*1 IN(N) CHARACTER*(*) OUT DO 10 I=1,N 10 OUT(I:I)=IN(I) END SUBROUTINE ERROR(STRING) C C Print 'string' as an error-message, and stop C C T.J.Pearson VAX-11 Fortran C 1982 January 7 * IBM VERSION * Portable version DFB 11-Feb-1991 C CHARACTER*(*) STRING C WRITE (6,1000)STRING 1000 FORMAT('0+++ERROR+++ ',A) STOP C END