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