Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0141/getnum.for
There are 4 other files named getnum.for in the archive. Click here to see a list.
      SUBROUTINE GETNUM(KONTRL,IBUFFR,MAXBFR,LOWBFR,KIND  ,
     1    IVALUE,VALUE )
C     RENBR(/GET NEXT NUMBER IN SINGLE LINE)
C
C     DONALD BARTH, HARVARD BUSINESS SCHOOL
C
C     KONTRL = 0, RETURN INTEGER AS ARGUMENT IVALUE
C            = 1, RETURN REAL NUMBER IN ARGUMENT VALUE
C     IBUFFR = TEXT TYPED BY USER READ WITH MULTIPLE OF A1
C              FORMAT
C     MAXBFR = NUMBER OF CHARACTERS IN IBUFFR
C     LOWBFR = INITIALLY SHOULD BE INPUT CONTAINING ZERO
C              TO ALLOW INITIAL COMMA TO INDICATE MISSING
C              ITEM.  THEREAFTER SHOULD BE INPUT CONTAINING
C              SUBSCRIPT OF NEXT LOCATION IN IBUFFR ARRAY
C              WHICH IS TO BE EXAMINED.
C            = RETURNED POINTING TO NEXT CHARACTER NOT YET
C              EXAMINED.
C     KIND   = 1, LINE IS EMPTY
C            = 2, ERROR MESSAGE TYPED TO USER
C            = 3, MISSING NUMBER
C            = 4, A NUMBER HAS BEEN EVALUATED
C     IVALUE = RETURNED CONTAINING INTEGER VALUE IF
C              KONTRL=0
C     VALUE  = RETURNED CONTAINING REAL VALUE IF KONTRL=1
C
      DIMENSION IBUFFR(MAXBFR)
      DATA IWHAT/1H?/
      DATA ITTY/5/
C
C     OBTAIN NEXT ITEM IN TEXT BUFFER
      MANY=1
      IF(LOWBFR.GT.0)GO TO 1
      LOWBFR=1
      MANY=0
    1 LOCK=MANY
      CALL DAMISS(KONTRL,1,0,IBUFFR,MAXBFR,
     1LOWBFR,KIND,ISHIFT,JSHIFT,KSHIFT,LSHIFT,IVALUE,
     2VALUE,MANY,LCNBFR,LCNERR)
      GO TO(5,12,6,6,2,4,14),KIND
C
C     TREAT SEMICOLON LIKE COMMA
    2 IF(LOCK.EQ.0)GO TO 3
      MANY=-1
      GO TO 1
    3 LOWBFR=LOWBFR-1
      GO TO 14
C
C     BUFFER IS EMPTY
    4 IF(MANY.LT.0)GO TO 14
    5 KIND=1
      GO TO 15
C
C     NUMBER FOUND
    6 IF(LSHIFT.LT.0)GO TO 8
      IF(KONTRL.GT.0)GO TO 7
      IF(KSHIFT.LT.0)GO TO 10
    7 KIND=4
      GO TO 15
C
C     ILLEGAL NUMBER REPRESENTATION
    8 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,9)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
    9 FORMAT(' NUMBER REQUIRED BUT NO VALUE DIGITS IN ',
     1132A1)
      KIND=2
      GO TO 15
   10 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,11)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
   11 FORMAT(' INTEGER REQUIRED BUT TENTHS SPECIFIED IN ',
     1132A1)
      KIND=2
      GO TO 15
C
C     UNKNOWN INITIAL CHARACTER
   12 LOWBFR=LCNERR
      LCNERR=LCNERR-1
      WRITE(ITTY,13)IWHAT,(IBUFFR(I),I=LCNBFR,LCNERR),IWHAT
   13 FORMAT(' NUMBER EXPECTED BUT INSTEAD FOUND ',132A1)
      KIND=2
      GO TO 15
C
C     MISSING NUMBER
   14 KIND=3
C
C     RETURN TO CALLING PROGRAM
   15 RETURN
C372999423353?'
      END