SUBROUTINE CALC
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 ***               CALC   MAINLINE                   ***
C
C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN 
C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
C POSSIBLE COMMANDS.
C
C    CALC CALLS
C
C  ASSIGN    OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
C  CLOSE     CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
C  CMND      DETERMINES WHAT CALC COMMAND IS REQUIRED.
C  ERRCX     CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
C  ERRMSG    PRINTS OUT ERROR MESSAGES.
C  EXIT      RETURNS TO OPERATING SYSTEM.
C  GETMCR    GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
C            IS PRESENT, CALC EXITS AFTER THAT ONE COMMAND IS EXECUTED.
C  INPOST    CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
C  LIST      LISTS THE LEGAL CALC COMMANDS.
C  POSTVL    CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
C            A VALUE.
C  SLEND     FINDS THE LAST NON-BLANK IN LINE(80).
C  VAROUT    PRINTS OUT THE VALUE OF A VARIABLE.
C  ZNEG      DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
C
C
C
C   VARIABLE      USE
C
C  BASED        DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
C  BLANK        ' '
C  DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C               SECOND SUBSCRIPT IS
C                     1 FOR DECIMAL
C                     2 FOR OCTAL
C                     3 FOR HEXADECIMAL
C  I,J          HOLD TEMPORARY VALUES.
C  ITCNTV(6)    INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C               INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C               HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C               USED TO CONTROL ITERATION.
C		THIS VARIABLE IS GUARANTEED TO BE 1-27.
C  LEND         POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
C  LEVEL        HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
C               LINES COME FROM.
C  LINE(80)     COMMAND INPUT LINE.
C  NONBLK       POINTS TO LAST NON-BLANK FOUND IN LINE(80).
C  ONCE         HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
C               0 OTHERWISE.
C  STAR         '*'
C  VIEWSW           VIEW SWITCH
C                    0 = OUTPUT ERROR MESSAGES
C                    1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C                    2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C                        EVALUATED.
C                    3 = OUTPUT EVERYTHING
C  WHAT         '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
C               SHOULD BE OUTPUT.
C
C	MODIFIED	REASON
C
C	18-MAY-1981	DELETED LINE THAT CAUSED DEFAULT BASE TO BE RESET
C			WHEN AN ERROR OCCURS (PB)
C
C	18-MAY-1981	ADDED CODE AT LINES 106 TO 108 TO CONVERT FROM LOWER
C			TO UPPER CASE  (PB)
C
C CHANGED TO SUBROUTINE GCE TO ALLOW EXTERNAL CONTROL OF CALCULATOR.
C
	INTEGER*2 LEVEL,NONBLK,LEND
	INTEGER*2 RETCD,VIEWSW,BASED
	INTEGER*2 ONCE
	INTEGER*2 ZNEG,ITCNTV(6)
C
	LOGICAL*1  LINE(80),WHAT,STAR,QUOTE
	LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
	LOGICAL*1 DIGITS(16,3)
	INTEGER*2 OSWIT,OCNTR,ILNFG,ILNCT
	LOGICAL*1 OARRY(100),ILINE(106)
	COMMON/OAR/OSWIT,OCNTR,OARRY
	COMMON/ILN/ILNFG,ILNCT,ILINE
C
	COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
	COMMON/KLVL/KLVL
	COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
	COMMON /DIGV/ DIGITS
	COMMON/ITERA/ITCNTV
C
	DATA  WHAT/'?'/, STAR/'*'/, QUOTE/''''/
	DATA ONCE/0/
C
C
C
C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
C THE MODULES PROPERLY, PUT IN A
	IF(KLVL.EQ.1)LEVEL=KLVL
	ONCE=0
	IF(ILNFG.NE.0) GOTO 6000
	CALL ASSIGN (1,'TI:')
6000	CONTINUE
C CHANGE TI: TO TT: FOR VMS.
C THE ADVANTAGE OF NOT DOING THIS IS THAT YOU CAN CREATE AN OUTPUT
C TEST FILE TO DISK TO HELP VERIFY CORRECTNESS AFTER A CHANGE TO THE
C SOURCE HAS BEEN MADE.
C
C
C
C GET MCR COMMAND LINE (RSX11-M CALL)
	IF(ILNFG.EQ.0)GOTO 6010
	IF(ILNCT.GT.0)GOTO 6010
C INVALID INPUTS...NO LINE TO DO BUT FLAGGED TO DO. CLEAN UP.
	ILNFG=0
	RETURN
6010	CONTINUE
	IF(ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6001
C ++++++
C FOR DEC FORTRAN:
C	CALL GETMCR(LINE,LEND)
C	IF(LEND)20,20,5
C FOR NON-DEC FORTRAN: (OR VAX VERSIONS)
	GOTO 20
C ++++++  END OF CHOICES...
5	CONTINUE
	GOTO 6003
6001	CONTINUE
	DO 6007 LENDX=1,80
6007	LINE(LENDX)=32
	IF(ILNFG.EQ.1)ONCE=1
	DO 6002 LENDX=1,ILNCT
	LINE(LENDX)=ILINE(LENDX)
	IF(LINE(LENDX).GT.0.AND.LINE(LENDX).LT.32)LINE(LENDX)=32
C LEAVE ANY EXISTING NULLS IN.
6002	CONTINUE
	LEND=ILNCT
CD	CALL FRMEDT(LINE,LEND)
C FRMEDT IMPLEMENTS EDITS OF {VAR INTO THAT VARIABLE'S FORMULA
CC NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
C	ICCC=MIN0(80,(LEND+1))
C	LINE(ICCC)=0
	GOTO 103
6003	CONTINUE
	DO 6 NONBLK=1,7
	IF(LINE(NONBLK).EQ.BLANK)GO TO 7
	IF(LINE(NONBLK).EQ.13)GO TO 20
6	CONTINUE
	STOP 6
7	NONBLK=NONBLK+1
	ONCE=1
	GO TO 106
C
C  ERROR RESET
10	IF(LEVEL.LE.1) GO TO 12
	CALL CLOSE(LEVEL)
	LEVEL=LEVEL-1
	GO TO 10
12	CONTINUE
	VIEWSW=3
C
C
C  GET NEXT INPUT LINE
20	CONTINUE
	LINE(1)=0
	LINE(2)=0
	IF(ONCE.EQ.1.AND.LEVEL.LE.1) RETURN
C20	IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL EXIT
C	IF (ILNFG.NE.0.AND.ILNCT.GT.0)GOTO 6004
	IF (LEVEL.LE.1.AND.ILNFG.NE.0.AND.ILNCT.GT.0)RETURN
	IF(LEVEL.LT.1)RETURN
	IF(ILNFG.EQ.0.AND.LEVEL.EQ.1)WRITE(1,22)
22	FORMAT(' CALC>',$)
C
C
	READ (LEVEL,24,END=900,ERR=1000) LINE
24	FORMAT (80A1)
C	GOTO 6005
C SECTION BELOW COMMENTED OUT BECAUSE IT SHOULD NEVER BE CALLED (GCE).
C6004	CONTINUE
C	DO 6006 LENDX=1,80
C6006	LINE(LENDX)=32
CC ABOVE BLANKS OUT LINE ARRAY
C	DO 6007 LENDX=1,ILNCT
C6007	LINE(LENDX)=ILINE(LENDX)
CC ABOVE COPIES INPUT FROM OUR CALLER...
C6005	CONTINUE
C
C
C
C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
CD	CALL FRMEDT(LINE,LEND)
	CALL SLEND(RETCD)
	GO TO(30,20),RETCD
	STOP 30
30	CONTINUE
C
C
C
	IF(ILNFG.EQ.0.AND.ILNCT.GT.0)GOTO 103
C SHOW WHAT WAS READ FROM FILE
	IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
     1 WRITE(1,40)LEVEL,(LINE(I),I=1,LEND)
40	FORMAT (' CALC<',I1,'>',80A1)
103	CONTINUE
C NULL TERMINATE THE LINE TO ENSURE WE END SOMEWHERE.
	ICCC=MIN0(80,(LEND+1))
	LINE(ICCC)=0
C
C  IDENTIFY FIRST NON-BLANK
	DO 104 NONBLK=1,LEND
	IF (LINE(NONBLK).NE.BLANK) GOTO 106
104	CONTINUE
	RETURN
C	STOP 104
C
C CONVERT LOWER CASE TO UPPER CASE
106	DO 108 I=NONBLK,LEND
	J=LINE(I)
	IF (I.EQ.NONBLK) GOTO 107
	IF (LINE(I-1).EQ.QUOTE) GOTO 108
107	IF(J.GE.97.AND.J.LE.122) LINE(I)=J-32
108	CONTINUE
C
C  SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
	IF (LINE(NONBLK).NE.WHAT) GOTO 110
	CALL LIST
	GOTO 20
C
C  SEE IF IT IS A COMMAND
110	IF (LINE(NONBLK).NE.STAR) GOTO 120
	CALL CMND (RETCD)
	GOTO (20,115,10,6120), RETCD
6120	RETURN
C	STOP 110
C
C
C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
115	CALL SLEND(RETCD)
	GO TO (103,20),RETCD
	RETURN
C	STOP 115
C
C  SEE IF ONLY ONE ALPHA CHARACTER
120	J=NONBLK+1
	IF (LEND.NE.NONBLK) GOTO 130
	DO 124 I=1,27
	IF (LINE (NONBLK).EQ.ALPHA(I)) GOTO 126
124	CONTINUE
C
C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
	DO 125 I=1,10
	IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
125	CONTINUE
C
C
C ALLOW FOR ENTERING THE ASCII BLANK
	IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
	I=1
	GOTO 1001
C
C  OUTPUT VALUE OF SINGLE VARIABLE
126	CALL VAROUT(I,1)
	GOTO 20
C
C
C CHECK INPUT FOR SYNTAX ERRORS
130	CALL ERRCX (RETCD)
	GOTO (140,10),RETCD
	RETURN
C	STOP 130
C
C  CHANGE FROM INFIX TO POSTFIX NOTATION
140	CALL INPOST (RETCD)
	GOTO (150,10), RETCD
C
C
C EVALUATE EXPRESSION
150	CONTINUE
	CALL POSTVL(RETCD)
	GOTO(20,10),RETCD
	RETURN
C	STOP 150
C
C
C  EXIT
900	CONTINUE
	IF (LEVEL.EQ.1) RETURN
C	IF (LEVEL.EQ.1) CALL EXIT
	IF(ITCNTV(LEVEL).EQ.0)GOTO 910
	IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
C
C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
C AND EXECUTE AGAIN.
	REWIND LEVEL
	GO TO 20
C
C
C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
C OF LEVEL BY ONE.
910	CALL CLOSE(LEVEL)
	LEVEL=LEVEL-1
	GOTO 20
C
C
C
C *** ERROR PROCESSING ***
1000	I=27
1001	CALL ERRMSG(I)
	GO TO 10
	END