SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
	INCLUDE 'VKLUGPRM.FTN'
C	PARAMETER RRW = 32
C	PARAMETER RCL = 32
C RRW=MAX REAL ROWS
C RCL=MAX REAL COLS
C RRW MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED RRW,RCL
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    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
C	SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C
C
C
	REAL*8 REAL,RB,ACX,XAC
C
	INTEGER*4 INT
C
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2 LASTOP
	INTEGER*2 VIEWSW,BASED,VLEN(9),DEFBAS
	INTEGER*2 TYPE(RRWP,RCLP)
	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
	LOGICAL*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
	LOGICAL*1 RETVAL(20)
	LOGICAL*1 FUNCT(10,40),FUNVAL(2,40)
	LOGICAL*1 AVBLS(20,27)
	EQUIVALENCE(XAC,AVBLS(1,27))
	LOGICAL*1 VBLS(8,RRWP,RCLP)
	LOGICAL*1 OPER(9),DIGITS(16,3)
	LOGICAL*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	LOGICAL*1 FOUR(4),EIGHT(8)
C
	COMMON /V/ TYPE,AVBLS,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,20
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
C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
C	CALL GETNNB (IPT,RETCD2)
C	IF (RETCD2.EQ.2) GOTO 12060
CC
CC
CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
C	DO 12050 I=1,27
C	IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
C12050	CONTINUE
C *****&&&&& ...ENDING HERE
C ADD BELOW...
	LLB=IPT
	LRB=LEND
	CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
C	IF(IVALID.EQ.0)GOTO 12200
C	IPT=LSTCHR
C	IF(IVALID.NE.0.AND.ID2.GT.1)GOTO 12201
	IF(IVALID.EQ.0)GOTO 13201
	IF(ID2.GT.1)GOTO 12201
	IF(ID2.EQ.1.AND.ID1.LE.RRW)GOTO 12201
13201	CONTINUE
C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
	I=IPT+9
	CALL FNAME(LINE(IPT),I,INDEXF)
	IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.21)GOTO 12202
C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
	LLAST=LEND-IPT+1
	I=INDEX(LINE(IPT),']')
	IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
	LRB=I
	LLB=INDEX(LINE(IPT),'[')
	IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
	CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
	XAC=ACX
	TYPE(1,1)=2
	CALL TYPSET(1,27,TYPE(1,1))
C	TYPE(27,1)=2
	ID1=27
	ID2=1
	LSTCHR=LRB+IPT
C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
C RETURN ITS VALUE.
	GOTO 12201
C IF NOT VALID FUNCTION REPORT AN ERROR.
12202	GOTO 12200
12201	IPT=LSTCHR
	IF(LSTCHR.LT.LEND)IPT=IPT-1
	NONBLK=IPT
C RESET NONBLK ALST SO WE RESET GETNNB TOO...
C WAS IPT=LSTCHR+1
C IPT POINTS AFTER VARIABLE NAME...
C ENSURE NON ALPHA AFTER VARIABLE NAME
	CALL GETNNB(IPT,RETCD2)
	IF(RETCD2.EQ.2) GOTO 12060
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	CALL TYPGET(ID1,ID2,RETTYP)
C12060	RETTYP=TYPE(ID1,ID2)
C *****&&&&&
C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
	IF (RETTYP.EQ.5)RETTYP=4
	IF (RETTYP.EQ.6)RETTYP=8
	IF (RETTYP.EQ.7)RETTYP=3
12061	CONTINUE
	IF(RETTYP.LE.0)GO TO 12080
	K=VLEN(RETTYP)
	DO 12070 I=1,K
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
C TO AVOID MULTIPLE ARBITRATION...
	IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
C	CALL VBLGET(I,ID1,ID2,RETVAL(I))
C	RETVAL(I)=VBLS(I,ID1,ID2)
	GOTO 12070
12068	RETVAL(I)=AVBLS(I,ID1)
12070	CONTINUE
C
12080	LASTOP=RETTYP
	GOTO 99099
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100	CONTINUE
C	RETVAL(1)=IALPHA
C	RETTYP=TYPE(IALPHA)
	CALL TYPGET(ID1,ID2,TYPE(1,1))
	CALL RVBOO(RETVAL,ID1,ID2)
C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
C AS 2 INTEGERS.
	RETTYP=TYPE(1,1)
	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.19) 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,19
	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(20)=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,20,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,19
	IF (RETVAL(L).NE.0) GOTO 40030
40022	CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
	L=19
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
40550	I2=I1
	I1=0
	GOTO 40530
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
	SUBROUTINE RVBOO(RETV,ID1,ID2)
C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
C ACCESS VARIABLE LOCATION LATER.
	INTEGER*2 RETV,ID1,ID2
	DIMENSION RETV(2)
	RETV(1)=ID1
	RETV(2)=ID2
	RETURN
	END