SUBROUTINE CALBIN(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 *                                                     *
C *             SUBROUTINE  CALBIN                      *
C *                                                     *
C *******************************************************
C
C  SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
C
C
C
C  UPON ENTRANCE TO ROUTINE:
C	OPERAND1 IS IN STACK1  (ST1PT-1)
C	OPERAND2 IS ON TOP OF STACK2  (ST2PT-1)
C	OPERATOR IS BELOW OPERAND2  (ST2PT-2)
C  UPON EXIT:
C	RESULT IS IN STACK1
C	STACK2 HAS BEEN CLEANED UP
C
C  RETURN CODE	MEANING
C	1	NORMAL RETURN
C	2	OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C	3	ERROR RETURN
C
C
C
C  MODIFICATION CLASSES: M3, M4, AND M8
C
C
C
C  CALBIN CALLS
C
C  CONTYP   CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
C  ERRMSG   PRINTS OUT ERROR MESSAGES
C  MULADD   PERFORMS MULTIPLE PRECISION ADDITION
C  MULDIV   PERFORMS MULTIPLE PRECISION DIVISION
C  MULMUL   PERFORMS MULTIPLE PRECISION MULTIPLICATION
C  
C
C
C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
C
C
C
C
C   VARIABLE     USE
C
C  EIGHT(8)      PICKS OUT A REAL CONSTANT FROM STACK.
C  FOUR(4)       PICKS OUT AN INTEGER CONSTANT FROM STACK.
C  I,J           HOLD TEMPORARY VALUES.
C  IA            FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
C                VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
C  ID            USED TO CONVERT DECISION TABLE LOGICAL*1 VALUE TO
C                AN INTEGER*2 VALUE THAT CAN BE USED AS AN ARGUMENT
C                IN A CALL TO CONTYP.
C  INT,IHOLD     HOLD INTEGER*4 VALUES.
C  IOP           HOLDS THE BINARY OPERATOR.
C  IOP2          USED TO INDEX A COMPUTED GO.
C  ISW           HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
C  MINUS         VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C                NUMBER THAT IS USED TO INDICATE A NEGATIVE.
C  OP1TYP        TYPE OF OPERAND 1.
C  OP2TYP        TYPE OF OPERAND 2.
C  PLUS          VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C                NUMBER THAT IS USED TO INDICATE POSITIVE.
C  PT1,PT2       POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
C  REAL,RHOLD    HOLD TEMPORARY REAL*8 VALUES.
C  RETCD         ERROR RETURN:  1 = O.K.   2 = RESULT WAS OUTPUT
C                3 = ERROR
C
C
C
C
C
C
C
C
C
C	SUBROUTINE CALBIN(RETCD)
	REAL*8 REAL,RHOLD,DFLOAT
C
	INTEGER*4 INT,IHOLD
C
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2 VLEN(9)
	INTEGER*2 IOP,IA,ID,IOP2,ISW
	INTEGER*2 PLUS,MINUS
	INTEGER*2 OLDTYP,VIEWSW,BASED
	INTEGER*2 TYPE(RRWP,RCLP)
	INTEGER*2 RETCD,RETCD2
	INTEGER*2 OP1TYP,OP2TYP
	INTEGER*2 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
	INTEGER*2 PT1,PT2
C
	LOGICAL*1 STACK1(20,40),STACK2(20,40)
	INTEGER*2 STK12(10,40)
	EQUIVALENCE(STK12(1,1),STACK1(1,1))
	LOGICAL*1 AVBLS(20,27), DTBL1(9,9,8)
	LOGICAL*1 VBLS(8,RRWP,RCLP)
	LOGICAL*1 EIGHT(8),FOUR(4)
	LOGICAL*1 LINE(80)
C
	EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
C
	COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON/V/ TYPE,AVBLS,VBLS,VLEN
	COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;         ST1LIM,ST2LIM
	COMMON /DECIDE/DTBL1
C
C
	DATA PLUS/0/,MINUS/1/
C
C
C
C
C
	RETCD=1
	PT1=ST1PT-1
	PT2=ST2PT-1
C
C
	IOP=ST2TYP(ST2PT-2)
	OP1TYP=ST1TYP(PT1)
	OP2TYP=ST2TYP(PT2)
C NOTE THAT IA IS UNUSED HERE... SAVE BIG DIMENSIONS
	IA=STACK1(1,PT1)
	ID1=STK12(1,PT1)
	ID2=STK12(2,PT1)
C	CALL GETDM(STACK1(1,PT1),ID1,ID2)
C ****&&&& ABOVE GETS LOCS IN 2 DIM ARRAY OF VARIABLES
	IF (IOP.NE.200) GOTO 100
C
C
C
C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
	IF(OP1TYP.GE.0) GO TO 5
C
C
C
C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
	OP1TYP=-OP1TYP
	ST1TYP(PT1)=OP1TYP
C
C
C
C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE  I=J=2
5	J=VLEN(OP2TYP)
C	TYPE(IA)=OP1TYP
	CALL TYPSET(ID1,ID2,OP1TYP)
C	TYPE(ID1,ID2)=OP1TYP
C *&*****&&&&& NOTE TYPE ARRAY AND VBLS ARRAY NOW ARE HUGE
C  NOTE FURTHER THAT AVBLS IS OLD VBLS ARRAY. SWITCHED ON IF
C ID1 =< 27 AND ID2=1.
	DO 10 I=1,J
10	STACK1(I,PT1)=STACK2(I,PT2)
	CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
	GOTO (20,9999), RETCD2
	STOP 20
C
C
C THE SPECIFIED VARIABLE GETS NEW VALUE.
C ***&&&& HERE'S WHERE WE STORE A VALUE INTO A VARIABLE...
20	J=VLEN(OP1TYP)
	DO 30 I=1,J
C	VBLS(I,IA)=STACK1(I,PT1)
	IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 22
	CALL VBLSET(I,ID1,ID2,STACK1(I,PT1))
C	VBLS(I,ID1,ID2)=STACK1(I,PT1)
	GOTO 30
22	AVBLS(I,ID1)=STACK1(I,PT1)
C *****&&&&&
30	CONTINUE
	GOTO 10000
C
C
C  IOP2 VALUES 1="**"  2="*"   3="/"   4="+"   5="-"
100	IOP2=IOP-111
	GOTO (1000,2000,2000,2000,2000),IOP2
C
C
C    ********************************************
C    ***********  EXPONENTIATION  ***************
C    ********************************************
C
C
C  FIRST CONVERT TO PROPER TYPE
1000	ID=DTBL1(OP2TYP,OP1TYP,5)
	CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	ID=DTBL1(OP2TYP,OP1TYP,6)
	CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
C
C
C  GOTO APPROPRIATE PLACE TO PERFORM OPERATION
	ID=DTBL1(OP2TYP,OP1TYP,8)
	GOTO (1100,1200,1300,1400,1500,1600,1700),ID
	STOP 1000
C
C
C  REAL**REAL
1100	DO 1104 I=1,8
1104	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 1108 I=1,8
1108	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD**REAL
C
C
C  USED BY REAL**I
1109	DO 1110 I=1,8
1110	STACK1(I,PT1)=EIGHT(I)
C
C
C  USED BY I**REAL,I**I
1114	ST1TYP(PT1)=DTBL1(OP2TYP,OP1TYP,7)
	GOTO 10000
C
C
C
C  REAL**I
1200	DO 1204 I=1,8
1204	EIGHT(I)=STACK1(I,PT1)
	DO 1208 I=1,4
1208	FOUR(I)=STACK2(I,PT2)
	REAL=REAL**INT
	GOTO 1109
C
C
C
C  I**REAL (PARTS USED BY I**I)
1300	DO 1304 I=1,4
1304	FOUR(I)=STACK1(I,PT1)
	DO 1308 I=1,8
1308	EIGHT(I)=STACK2(I,PT2)
C
C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
C
	INT=DFLOAT(INT)**REAL
1310	DO 1314 I=1,4
1314	STACK1(I,PT1)=FOUR(I)
	GOTO 1114
C
C
C
C  I**I
1400	DO 1404 I=1,4
1404	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 1408 I=1,4
1408	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD**INT
	GOTO 1310
C
C
C
C  M8**I    (PARTS USED BY M10**I, M16**I)
1500	ISW=8
1501	IF(ST2PT.LE.ST2LIM)GO TO 1502
C
C
C STACK OVERFLOW
	CALL ERRMSG(9)
	GO TO 9999
C
C
C GET EXPONENT AS AN INTEGER
1502	DO 1504 I=1,4
1504	FOUR(I)=STACK2(I,PT2)
	IF (INT.GE.0) GOTO 1520
C
C
C EXPONENT NOT POSITIVE OR 0
	CALL ERRMSG (15)
	GOTO 9999
1520	IF (INT.GT.0) GOTO 1530
C
C
C I**0 = 1
	STACK1(20,PT1)=PLUS
	DO 1522 I=2,19
1522	STACK1(I,PT1)=0
	STACK1(1,PT1)=1
	GOTO 10000
C
C
C EXPONENT IS > 0
1530	INT=INT-1
C
C
C IF EXPONENT = 1 WE ARE DONE
	IF(INT.EQ.0)GO TO 10000
C
C
C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
C FACTOR.
	DO 1534 I=1,20
1534	STACK2(I,ST2PT)=STACK1(I,PT1)
	ST2TYP(ST2PT)=ST1TYP(PT1)
C
C
C
C
1549	DO 1550 I=1,INT
	CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
	IF(RETCD2.GE.2)GO TO 9999
1550	CONTINUE
	GOTO 10000
C
C  M10**I
1600	ISW=10
	GOTO 1501
C
C
C
C  M16**I
1700	ISW=16
	GOTO 1501
C
C
C
C
C
C
C
C  *****************************************
C  * MAKE CONVERSIONS APPROPRIATE FOR */+- *
C  *****************************************
2000	CONTINUE
	ID=DTBL1(OP2TYP,OP1TYP,1)
	CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	IF(ID.EQ.0)GO TO 2010
	ST1TYP(PT1)=ID
	OP1TYP=ID
2010	ID=DTBL1(OP2TYP,OP1TYP,2)
	CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
	IF (RETCD2.EQ.2) GOTO 9999
	IF(ID.EQ.0)GOTO 2020
	ST2TYP(PT2)=ID
	OP2TYP=ID
C
2020	CONTINUE
C
C
C  GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
	GOTO (2100,3000,4000,5000,6000),IOP2
2100	STOP 2100
C
C
C
C
C
C
C  **********************************************
C  ***********  MULTIPLICATION  *****************
C  **********************************************
3000	ID=DTBL1(OP2TYP,OP1TYP,4)
	GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
	STOP 3000
C
C
C  ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
3100	CALL ERRMSG (12)
	GOTO 9999
C
C
C  DECIMAL, REAL
3200	DO 3204 I=1,8
3204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 3208 I=1,8
3208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD*REAL
3209	DO 3210 I=1,8
3210	STACK1(I,PT1)=EIGHT(I)
C
C
C  FOLLOWING USED BY OTHER SECTIONS
3220	ST1TYP(PT1)=DTBL1(OP2TYP,OP1TYP,3)
	GOTO 10000
C
C
C
C  HEX,INTEGER,OCTAL
3300	DO 3304 I=1,4
3304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 3308 I=1,4
3308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD*INT
3309	DO 3310 I=1,4
3310	STACK1(I,PT1)=FOUR(I)
	GOTO 3220
C
C
C
C  M10
3500	CALL MULMUL (PT1,PT2,RETCD2,10)
C
C
C  FOLLOWING USED BY OTHER SECTIONS
3510	IF (RETCD2.EQ.2) GOTO 9999
	GOTO 3220
C
C
C
C  M8
3600	CALL MULMUL (PT1,PT2,RETCD2,8)
	GOTO 3510
C
C
C
C  M16
3700	CALL MULMUL (PT1,PT2,RETCD2,16)
	GOTO 3510
C
C
C
C
C
C
C  **************************************************
C  ******************  DIVISION  ********************
C  **************************************************
4000	ID=DTBL1(OP2TYP,OP1TYP,4)
	GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
	STOP 4000
C
C
C  DECIMAL,REAL
4200	DO 4204 I=1,8
4204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 4208 I=1,8
4208	EIGHT(I)=STACK2(I,PT2)
	IF(REAL.NE.0.D0)GO TO 4210
	CALL ERRMSG(23)
	GO TO 9999
4210	REAL=RHOLD/REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
4300	DO 4304 I=1,4
4304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 4308 I=1,4
4308	FOUR(I)=STACK2(I,PT2)
	IF(INT.NE.0)GO TO 4310
	CALL ERRMSG(23)
	GO TO 9999
4310	INT=IHOLD/INT
	GOTO 3309
C
C
C  M10
4500	CALL MULDIV (PT1,PT2,RETCD2,10)
	GOTO 3510
C
C
C  M8
4600	CALL MULDIV (PT1,PT2,RETCD2,8)
	GOTO 3510
C
C
C  M16
4700	CALL MULDIV (PT1,PT2,RETCD2,16)
	GOTO 3510
C
C
C
C
C
C **************************************************
C *****************  ADDITION  *********************
C **************************************************
C
5000	ID=DTBL1(OP2TYP,OP1TYP,4)
	GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
	STOP 5000
C
C
C  DECIMAL, REAL
5200	DO 5204 I=1,8
5204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 5208 I=1,8
5208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD+REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
5300	DO 5304 I=1,4
5304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 5308 I=1,4
5308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD+INT
	GOTO 3309
C
C
C  M10
5500	CALL MULADD (PT1,PT2,RETCD2,1)
	GOTO 3510
C
C
C  M8
5600	CALL MULADD (PT1,PT2,RETCD2,2)
	GOTO 3510
C
C
C  M16
5700	CALL MULADD(PT1,PT2,RETCD2,3)
	GOTO 3510
C
C
C
C
C
C
C  ***************************************************
C  ******************  SUBTRACTION  ******************
C  ***************************************************
C
6000	ID=DTBL1(OP2TYP,OP1TYP,4)
	GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
	STOP 6000
C
C
C  DECIMAL,REAL
6200	DO 6204 I=1,8
6204	EIGHT(I)=STACK1(I,PT1)
	RHOLD=REAL
	DO 6208 I=1,8
6208	EIGHT(I)=STACK2(I,PT2)
	REAL=RHOLD-REAL
	GOTO 3209
C
C
C  HEX,INTEGER,OCTAL
6300	DO 6304 I=1,4
6304	FOUR(I)=STACK1(I,PT1)
	IHOLD=INT
	DO 6308 I=1,4
6308	FOUR(I)=STACK2(I,PT2)
	INT=IHOLD-INT
	GOTO 3309
C
C
C  M10
6500	CALL MULADD (PT1,PT2,RETCD2,4)
	GOTO 3510
C
C
C  M8
6600	CALL MULADD (PT1,PT2,RETCD2,5)
	GOTO 3510
C
C
C  M16
6700	CALL MULADD (PT1,PT2,RETCD2,6)
	GOTO 3510
C
C
C
C
C
C	EXIT
9999	RETCD=3
C
C
C
10000	ST2PT=ST2PT-2
	RETURN
	END