Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0001/nextel.for
There is 1 other file named nextel.for in the archive. Click here to see a list.
C
C
C
C            COPYRIGHT (c) 1977 BY
C    DIGITAL EQUIPMENT CORPORTATION, MAYNARD, MASS.
C   
C  THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND  COPIED
C  ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH  LICENSE AND WITH THE
C  INCLUSION OF THE  ABOVE COPYRIGHT NOTICE.  THIS  SOFTWARE OR ANY OTHER
C  COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE  MADE AVAILABLE TO ANY
C  OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE  SOFTWARE  IS  HEREBY
C  TRANSFERRED.
C 
C  THE INFORMATION IN THIS  SOFTWARE IS SUBJECT TO CHANGE  WITHOUT NOTICE
C  AND  SHOULD  NOT  BE  CONSTRUED AS A COMMITMENT BY  DIGITAL  EQUIPMENT
C  CORPORATION.
C 
C  DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C  SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C 
C 
C 
C
C
C
C
C
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C   +                                                +
C   +            CALC    VERSION  X01-01             +
C   +                                                +
C   +  PETER BAUM  1-SEP-77                          +
C   +  DIGITAL EQUIPMENT CORPORATION                 +
C   +  146 MAIN STREET                               +
C   +  MAYNARD, MASSACHUSETTS  01754                 +
C   +                                                +
C   ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C
C
C **************************************************
C *                                                *
C *    SUBROUTINE NEXTEL(RETVAL,RETTYP,RETCD)      *
C *                                                *
C **************************************************
C
C
C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
C
C  RETCD  =	1  IF OPERAND (VALUE IN RETVAL(100)
C		2  IF OPERATOR (VALUE IN RETTYP)
C		3  NO MORE ELEMENTS
C		4  IF ERROR
C
C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
C	   A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
C
C  RETTYP  IS THE TYPE CODE
C
C
C
C
C MODIFY CODES: M1,M2,M3,M4,M8
C
C
C
C
C  NOTE: BECAUSE OF THE LENGTH AND COMPLEXITY OF THIS ROUTINE,
C        THE FLOWCHART MADE OF THE LOGIC FLOW IS VERY USEFUL.
C
C
C
C
C NEXTEL CALLS
C
C ERRMSG     PRINTS OUT ERROR MESSAGES
C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
C
C
C
C
C NEXTEL IS CALLED BY INPOST
C
C
C
C
C
C    VARIABLE    USE
C    ---------   ----------------------------------
C
C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
C
C    ARROW       '^'
C
C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
C
C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
C                DIGIT A, B, C, D, E, OR F WAS FOUND.
C
C    BASE        HOLDS BASE OF CONSTANT.
C
C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
C
C    DEFBAS      THE DEFAULT BASE SPECIFIED.
C
C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
C                 8, 10, AND 16.
C
C    DOT          '.'
C
C    EQ           '='
C
C    EXCODE       CODE FOR EXPONENTIATION.
C
C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
C
C    FUNCT (NAME,INDEX) HOLDS FUNCTION NAMES.
C
C    FUNVAL(I,J)
C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
C
C    
C
C    I,J,K,L  HOLDS TEMPORARY VALUES
C
C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
C
C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
C
C    IHOLD    HOLDS TEMPORARY VALUES
C
C    INT      PICKS UP INTEGER*4 VALUES.
C
C    IPT      POINTER TO ELEMENTS IN LINE(80).
C
C    IPT2     POINTER TO ELEMENTS IN LINE(80).
C
C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
C
C    MINUS   '-'
C
C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
C
C    PLUS    '+'
C
C    QUOTE   "'"
C
C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
C
C    REAL    PICKS UP REAL*8 CONSTANTS.
C
C    RETCD   RETURN CODE:
C              1 IF OPERAND (VALUE IN RETVAL(100))
C              2 IF OPERATOR (VALUE IN RETTYP)
C              3 NO MORE ELEMENTS.
C              4 IF ERROR.
C
C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
C
C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
C
C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
C
C    TYPE    TYPE CODE FOR EACH VARIABLE.
C
C    VBLS    HOLDS VALUE OF VARIABLES.
C
C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
C
C
C
C
C
C
C
C ***********************************************************
C *							    *
C *	LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION   *
C *							    *
C ***********************************************************
C
C
C
C
C
C
C
C
	SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C
C
C
	REAL*8 REAL,RB
C
	INTEGER*4 INT
C
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2 LASTOP
	INTEGER*2 VIEWSW,BASED,TYPE(27),VLEN(9),DEFBAS
	INTEGER*2 RETCD,RETCD2,RETTYP,EXCODE
	INTEGER*2 B10,B16,RETPT,BASE
	INTEGER*2 FCNT,AHOLD
	INTEGER*2 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
C
	INTEGER CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
	INTEGER RETVAL(100)
	INTEGER FUNCT(10,40),FUNVAL(2,40)
	INTEGER VBLS(100,27)
	INTEGER OPER(9),DIGITS(16,3)
	INTEGER LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	INTEGER FOUR(4),EIGHT(8)
C
	COMMON /V/ TYPE,VBLS,VLEN
	COMMON /DIGV/ DIGITS
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /ERROR/ LASTOP
C
	EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
C
	DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
	DATA MINUS/'-'/,PLUS/'+'/
	DATA OPER/'(','-','!','*','/','+','-',')','='/
C
C  NUMBER OF FUNCTIONS
	DATA FCNT/24/
C
	DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
     ;             'D','A','B','S',' ',' ',' ',' ',' ',' ',
     ;             'I','A','B','S',' ',' ',' ',' ',' ',' ',
     ;             'F','L','O','A','T',5*' ',
     ;             'I','F','I','X',6*' ',
     ;             'A','I','N','T',6*' ',
     ;             'I','N','T',7*' ',
     ;             'I','D','I','N','T',5*' ',
     ;             'E','X','P',7*' ',
     ;             'D','E','X','P',6*' ',
     ;             'A','L','O','G','1','0',4*' ',
     ;             'D','L','O','G','1','0',4*' ',
     ;             'A','L','O','G',6*' ',
     ;             'D','L','O','G',6*' ',
     ;             'S','Q','R','T',6*' ',
     ;             'D','S','Q','R','T',5*' ',
     ;             'S','I','N',7*' ',
     ;             'D','S','I','N',6*' ',
     ;             'C','O','S',7*' ',
     ;             'D','C','O','S',6*' ',
     ;             'T','A','N','H',6*' ',
     ;             'D','T','A','N','H',5*' ',
     ;             'A','T','A','N',6*' ',
     ;             'D','A','T','A','N',5*' ',
     ;             160*' '/
	DATA EXCODE/112/
       DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
     ;6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
     ;       4,44,5,44,32*0/
C
C
C
10	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 50
C
C  NO MORE ELEMENTS
	LASTOP=0
	RETCD=3
	RETURN
C
C
C  INITIALIZE VARIABLES
50	CONTINUE
	B10=0
	B16=0
	RETTYP=0
	RETPT=0
	REAL=0.D0
	RETCD=1
	DEFBAS=BASED
	DO 60 I=1,100
60	RETVAL(I)=0
C
70	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C  SEE IF ALPHABETIC OR %
	DO 80 I=1,27
	IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
80	CONTINUE
C
C
C  NOT ALPHA SO SEE IF AN OPERATOR
	DO 100 I=1,9
	IF (CHAR1.EQ.OPER(I)) GOTO 20000
100	CONTINUE
C
C
C SEE IF AN OPERAND
140	DO 150 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
150	CONTINUE
C
C
C
	IF (CHAR1.EQ.DOT) GOTO 40000
C
C
C
	IF (CHAR1.EQ.ARROW) GOTO 300
C
C
C
	IF (CHAR1.EQ.QUOTE) GOTO 200
C
C
C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
C
C
C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
190	CALL ERRMSG (20)
	GOTO 99000
C
C
C
C
C **************************************
C ****** ASCII CONSTANT SPECIFIED ******
C **************************************
200	CONTINUE
	NONBLK=NONBLK+1
	RETVAL(1)=LINE(NONBLK)
	RETTYP=1
	GOTO 35100
C
C
C
C
C **************************************
C ****** IMMEDIATE BASE SPECIFIED ******
C **************************************
300	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 320
C
C
C *** ERROR *** ILLEGAL BASE SPECIFICATION
310	CALL ERRMSG(19)
	GOTO 99000
C
C
C  IMMEDIATE BASE SPECIFICATION
320	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
	IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
C
C
C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
	IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
	IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
C
C
C IMMEDIATE BASE IS 16
	DEFBAS=16
	GOTO 370
C
C
C IMMEDIATE BASE IS 8
360	DEFBAS=8
	GOTO 370
C
C
C IMMEDIATE BASE IS 10
365	DEFBAS=10
C
C
C
370	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 310
	CHAR1=LINE(IPT)
	NONBLK=IPT
C
C
C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
	GOTO 140
C
C
C  
C
C ****************************************************
C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
C ****************************************************
10000	CONTINUE
	IALPHA=I
	IHOLD=NONBLK
C
C
C SCAN EACH OF THE FUNCTION NAMES.
	DO 10060 I=1,FCNT
C
C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
	K=FUNVAL(1,I)
	IPT2=IHOLD
	NONBLK=IHOLD
	IF (K.EQ.0) GOTO 10060
C
C
C SCAN EACH LETTER OF THE FUNCTION'S NAME
	DO 10050 J=1,K
	IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
	IF (J.EQ.K) GOTO 10100
	CALL GETNNB (IPT2,RETCD2)
	IF (RETCD2.EQ.2) GOTO 10060
	NONBLK=IPT2
10050	CONTINUE
	STOP 10050
C
10060	CONTINUE
10070	NONBLK=IHOLD
	GOTO 12000
C
C
C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
10100	CONTINUE
C
C
C
C
C **********************************
C ****** UNARY FUNCTION FOUND ******
C **********************************
	RETTYP=FUNVAL(2,I)
	LASTOP=RETTYP
	RETCD=2
	GOTO 99099
C
C
C
C
C
C ********************************
C ****** VARIABLE SPECIFIED ******
C ********************************
12000	CONTINUE
C
C
C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.2) GOTO 12060
C
C
C MAKE SURE NEXT CHARACTER IS NOT ALPHA
	DO 12050 I=1,27
	IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
12050	CONTINUE
C
C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
C OF RETVAL.
	IF (LINE(IPT).EQ.EQ) GOTO 12100
C
C
C ************************************************
C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
C ************************************************
12060	RETTYP=TYPE(IALPHA)
	IF(RETTYP.LE.0)GO TO 12080
	K=VLEN(RETTYP)
	DO 12070 I=1,K
12070	RETVAL(I)=VBLS(I,IALPHA)
C
12080	LASTOP=RETTYP
	GOTO 99099
C
C
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100	CONTINUE
	RETVAL(1)=IALPHA
	RETTYP=TYPE(IALPHA)
	GOTO 12080
C
C
C
C *** ERROR *** UNIDENTIFIED FUNCTION
12200	CALL ERRMSG(18)
	GOTO 99000
C
C
C
C
C
C **********************
C ****** OPERATOR ******
C **********************
C
C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
20000	CONTINUE
	RETCD=2
	IF(I.NE.4)GO TO 20050
C
C
C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
	CALL GETNNB (IPT,RETCD2)
	IF(RETCD2.NE.1)GO TO 99000
	IF (LINE(IPT).NE.STAR) GOTO 20050
C
C
C '**' SPECIFIED (EXPONENTIATION)
	RETTYP=EXCODE
	NONBLK=IPT
	GO TO 12080
C
C
C
C  SET DEFAULT RETTYP FOR OPERATORS
20050	RETTYP=109+I
C
C
C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
	IF (RETTYP.NE.111) GOTO 20080
C
C
C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
C IS UNARY.
	IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
     ;      LASTOP.EQ.200) GOTO 20090
C
C
C  BINARY SUBTRACTION OPERATOR
	RETTYP=116
	GOTO 12080
C
C
C
C SEE IF A '+' SIGN
20080	IF(RETTYP.NE.115)GO TO 20085
C
C
C DETERMINE IF IT IS A UNARY PLUS
	IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
C
C
C SEE IF LAST OPERATOR WAS ')'
	IF(LASTOP.EQ.117)GO TO 20085
C
C
C UNARY '+' FOUND.
	RETCD=1
	GO TO 10
C
C
C
C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
C IF RETTYP IS FOR =, SET TO PROPER CODE
20085	IF(RETTYP.EQ.110)GO TO 20090
	IF(RETTYP.EQ.118)RETTYP=200
	GO TO 12080
C
C
C UNARY -
20090	CONTINUE
	GOTO 99097
C
C
C
C
C
C
C *************************
C ****** NON-DECIMAL ******
C *************************
C
30000	RETPT=RETPT+1
	IF (RETPT.LE.99) GOTO 30020
C
C
C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 99 DIGITS
	CALL ERRMSG(22)
	GOTO 99000
C
C
C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
30020	IF (I.NE.16) GOTO 30030
	I=0
	GOTO 30050
30030	IF (I.EQ.8.OR.I.EQ.9) B10=1
	IF(I.GT.9) B16=1
30050	RETVAL(RETPT)=I
C
C
C GET NEXT CHARACTER
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.NE.1) GOTO 30100
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 30070 I=1,16
	IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
30070	CONTINUE
	IF (CHAR1.EQ.DOT) GOTO 40000
	NONBLK=NONBLK-1
30100	CONTINUE
C
	IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
	IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
C
C
C *****************************
C ****** BASE 8 CONSTANT ******
C *****************************
	BASE=8
C
C
C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
	IF (RETPT.GT.10) GOTO 30170
	RETTYP=8
C
C
C  CONVERT TO OCTAL, HEX OR INTEGER
30110	INT=0
30130	DO 30132 L=1,99
	IF (RETVAL(L).NE.0) GOTO 30140
30132	CONTINUE
30140	DO 30150 I=L,RETPT
	INT=INT*BASE+RETVAL(I)
	RETVAL(I)=0
30150	CONTINUE
	RETVAL(100)=0
30155	DO 30160 I=1,4
30160	RETVAL(I)=FOUR(I)
	GOTO 35100
C
C
C ************************************************
C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
C ************************************************
30170	RETTYP=6
30180	CALL FLIP (RETVAL,100,RETPT)
	GOTO 35100
C
C
C
C *********************
C ****** BASE 16 ******
C *********************
30200	BASE=16
C
C
C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.7) GOTO 30270
C
C
C
C  HEXADECIMAL
	RETTYP=3
	GOTO 30110
C
C
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 16 ******
C ****************************************
30270	RETTYP=7
	GOTO 30180
C
C
C *********************
C ****** BASE 10 ******
C *********************
30300	BASE=10
C
C
C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
	IF (RETPT.GT.9) GOTO 30370
C
C
C  INTEGER
	RETTYP=4
	GOTO 30110
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 10 ******
C ****************************************
30370	RETTYP=5
	GOTO 30180
C
C
C
C
C
C SET LASTOP AND EXIT
35100	LASTOP=RETTYP
	GOTO 99099
C
C
C *****************************
C ****** REAL OR DECIMAL ******
C *****************************
40000	IF (B16.NE.1) GOTO 40020
C
C
C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
	CALL ERRMSG(21)
	GOTO 99000
C
C
C
40020	IF (RETPT.EQ.0) GOTO 40200
C
C
C IGNORE LEADING ZEROES
	DO 40022 L=1,99
	IF (RETVAL(L).NE.0) GOTO 40030
40022	CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
	L=99
C
C
C CONVERT TO A REAL*8 NUMBER
40030	CONTINUE
	REAL=0.D0
	DO 40060 I=L,RETPT
	REAL=REAL*10.D0+RETVAL(I)
	RETVAL(I)=0
40060	CONTINUE
C
C
C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
40200	CONTINUE
	RB=1.0D0
	RETTYP=2
40205	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40300
C
C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
	GOTO 40537
C
C
C
40300	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40320 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
40320	CONTINUE
	GOTO 40350
40330	IF (I.EQ.10) I=0
	RB=0.1D0*RB
	REAL=REAL+DFLOAT(I)*RB
	GOTO 40205
C
C
C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
40350	IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
	NONBLK=NONBLK-1
	GO TO 40537
C
C
C *********************************************
C ****** E AND D EXPONENT SPECIFICATIONS ******
C *********************************************
40360	CONTINUE
	CALL GETNNB(IPT,RETCD2)
	IF (RETCD2.EQ.1) GOTO 40370
C
C
C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
40365	CALL ERRMSG (24)
	GOTO 99000
C
C
40370	CHAR1=LINE(IPT)
	IF (CHAR1.EQ.MINUS) GOTO 40380
	RB=10.D0
	IF (CHAR1.NE.PLUS) GOTO 40400
	GOTO 40390
40380	RB=0.1D0
C
C
C
40390	NONBLK=IPT
	CALL GETNNB (IPT,RETCD2)
40400	IF (RETCD2.GE.2) GOTO 40365
	NONBLK=IPT
	CHAR1=LINE(IPT)
	DO 40450 I=1,10
	IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
40450	CONTINUE
	GOTO 40365
40480	IF (I.EQ.10) I=0
C
C
C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
	I1=I
	CALL GETNNB (IPT,RETCD2)
	IF (RETCD2.GE.2) GOTO 40550
	CHAR1=LINE(IPT)
	NONBLK=IPT
	DO 40500 I=1,10
	IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
40500	CONTINUE
	NONBLK=NONBLK-1
	GOTO 40550
C
C
C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
40520	IF (I.EQ.10) I=0
	I2=I
C
C
40530	RETTYP=9
	REAL=REAL*RB**(I1*10+I2)
C
C
C
C ***************************************************
C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
C ***************************************************
40537	DO 40540 I=1,8
40540	RETVAL(I)=EIGHT(I)
	GOTO 35100
C
C
C
C
C
C
C
40550	I2=I1
	I1=0
	GOTO 40530
C
C
C
C
C
C
C
C ********************************
C ******* ERROR PROCESSING *******
C ********************************
99000	CONTINUE
	WRITE (1,99010) (LINE(I),I=NONBLK,LEND)
99010	FORMAT (1X,80A1)
	RETCD=4
99097	LASTOP=0
99099	RETURN
	END