PROGRAM CALCUL IMPLICIT DOUBLE PRECISION (D) BYTE NUMBER(26),RES,CHAR,FMT(10),ROLUP(16),ROLDWN(12),DFAC BYTE FUN(4),HULP(28),ERR,RES0 DOUBLE PRECISION X,Y(20),PI,RAD,XROL,X0 DIMENSION NERR(5) DATA IE/6/ C DATA of the COMMON variables should be set in HR:CALC2.MAC COMMON X,Y,IY,NUMBER,IN,HULP,IH,RES,CHAR,NERR,ICLR, * IERROR,IFMT,FMT,ROLUP,ROLDWN,ERR 1 FORMAT(I2) C DO 10, I=1,5 10 CALL SETERR(NERR(I),128) ! ignore errors C 20 CALL TTINIT ! initialize terminal C 30 DO 40, I=1,26 40 NUMBER(I)=0 ! clear input string IN=1 RES=.FALSE. CALL IPRINT(1) ! print zero string C 50 CALL INCHAR ! get input IERROR=0 ERR=.FALSE. RES0=RES IE=6 C IF (CHAR.NE."15) GOTO 60 ! return key typed ICLR=ICLR+1 IF (ICLR.LT.2) GOTO 30 ! once or twice ICLR=0 IY=0 GOTO 20 C 60 ICLR=0 IF (CHAR.NE.1) GOTO 80 IF (IY.LE.1) GOTO 50 CALL IPRINT(2) ! rol stack up IERROR=2 ENCODE(2,1,ROLUP(3),ERR=999) 23-IY ROLUP(3)=ROLUP(3).OR.'0' CALL IPRINT(7) XROL=Y(1) DO 70, I=2,IY 70 Y(I-1)=Y(I) Y(IY)=XROL IF (IWRITE(IY)) GOTO 999 CALL IPRINT(3) GOTO 50 C 80 IF (CHAR.NE.2) GOTO 100 IF (IY.LE.1) GOTO 50 CALL IPRINT(2) ! rol stack down IERROR=2 ENCODE(2,1,ROLDWN(9),ERR=999) 23-IY ROLDWN(9)=ROLDWN(9).OR.'0' CALL IPRINT(8) XROL=Y(IY) DO 90, I=IY,2,-1 90 Y(I)=Y(I-1) Y(1)=XROL IF (IWRITE(1)) GOTO 999 CALL IPRINT(3) GOTO 50 C 100 IF (CHAR.NE.-6) GOTO 110 DECODE(2,1,FMT(8),ERR=102) IFMT ! check output format IF (IFMT.LE.16) GOTO 104 IFMT=16 101 IERROR=2 ENCODE(2,1,FMT(8),ERR=999) IFMT GOTO 104 102 IFMT=8 GOTO 101 104 CALL DIGIT GOTO 50 C 110 IF (CHAR.NE.'='.AND.CHAR.NE."12) GOTO 120 IF (IY.EQ.20) GOTO 50 IY=IY+1 ! mov number to stack ERR=IDECOD(1) IF (ERR) GOTO 108 CALL IPRINT(2) CALL IPRINT(4) ERR=IWRITE(IY) 108 IF (CHAR.EQ."12) GOTO 112 IF (IMPENT()) GOTO 111 111 IF (ERR) GOTO 999 GOTO 30 112 IF (ERR) GOTO 999 CALL IPRINT(3) GOTO 50 C 120 IF (CHAR.NE."27) GOTO 150 ! rewrite screen 122 CALL TTINIT IF (IY.EQ.0) GOTO 140 DO 130, N=1,IY CALL IPRINT(4) 130 IF (IWRITE(N+0)) GOTO 999 140 CALL IPRINT(1) N=-2 IF (RES) N=-1 IF (IWRITE(N)) GOTO 999 GOTO 50 C 150 IF (CHAR.NE.-10) GOTO 160 ! delete number IF (IY.LT.1) GOTO 50 IY=IY-1 CALL IPRINT(11) GOTO 50 C 160 IF (CHAR.NE.16.AND.CHAR.NE.-16) GOTO 170 I=-1 IF (CHAR.LT.0) I=-2 IF (IERROR.EQ.3) GOTO 997 IF (IERROR.EQ.9) GOTO 997 GOTO 50 C 170 CALL IPRINT(2) ERR=IDECOD(0) X0=X IF (CHAR.LT.0) GOTO 190 IF (CHAR.GE.'A'.AND.CHAR.LE.'Z') GOTO 180 C C IF (CHAR.EQ.'+') CALL SCOPY('ADD',FUN) C IF (CHAR.EQ.'-') CALL SCOPY('SUB',FUN) C IF (CHAR.EQ.'*') CALL SCOPY('MUL',FUN) C IF (CHAR.EQ.'/') CALL SCOPY('DIV',FUN) C IF (CHAR.EQ.'^') CALL SCOPY('M',FUN) C IF (.NOT.ERR) IERROR=5 ERR=ERR.OR.IY.LT.1 IF (ERR) GOTO 200 IF (CHAR.EQ.'+') X=Y(IY)+X IF (CHAR.EQ.'-') X=Y(IY)-X IF (CHAR.EQ.'*') X=Y(IY)*X IF (CHAR.EQ.'/') X=Y(IY)/X IF (CHAR.EQ.'^') X=Y(IY)**X IY=IY-1 CALL IPRINT(5) GOTO 200 C 180 FUN(1)=CHAR FUN(2)=0 IF (CHAR.EQ.'A') X=DABS(X) IF (CHAR.EQ.'C') X=DCOS(X) IF (CHAR.EQ.'D') X=X*RAD() IF (CHAR.EQ.'E') X=DEXP(X) IF (CHAR.EQ.'F') ERR=ERR.OR.DFAC() 182 IF (CHAR.EQ.'I') X=DBLE(FLOAT(IDINT(X))) ! CALL DINT IF (CHAR.EQ.'K') X=X*X IF (CHAR.EQ.'L') X=DLOG10(X) IF (CHAR.EQ.'O') CALL OCTDEC(0) IF (CHAR.EQ.'P') X=PI() IF (CHAR.EQ.'R') X=1D0/X IF (CHAR.EQ.'S') X=DSIN(X) IF (CHAR.NE.'T') GOTO 184 XROL=DCOS(X) IF (.NOT.ERR) IERROR=6 ERR=ERR.OR.XROL.EQ.0D0 IF (ERR) GOTO 200 X=DSIN(X)/XROL GOTO 200 184 IF (CHAR.NE.'X') GOTO 200 IF (.NOT.ERR) IERROR=5 ERR=ERR.OR.IY.LT.1 IF (ERR) GOTO 200 X=X*Y(IY)*1D-2 GOTO 200 C 190 CHAR=-CHAR FUN(1)='/' FUN(2)=CHAR FUN(3)=0 IF (.NOT.ERR) IERROR=7 ERR=ERR.OR.((CHAR.EQ.'S'.OR.CHAR.EQ.'C').AND.DABS(X).GT.1) IF (ERR) GOTO 200 IF (CHAR.EQ.'A') X=-DABS(X) IF (CHAR.EQ.'C') X=DACOS(X) IF (CHAR.EQ.'D') X=X*DEG() IF (CHAR.EQ.'E') X=DLOG(X) IF (CHAR.EQ.'I') X=DMOD(X,1D0) ! CALL DMOD IF (CHAR.EQ.'K') X=DSQRT(X) IF (CHAR.EQ.'L') X=1D1**X IF (CHAR.EQ.'O') CALL OCTDEC(1) IF (CHAR.EQ.'S') X=DASIN(X) IF (CHAR.EQ.'T') X=DATAN(X) C 200 RES=.TRUE. IF (ERR) GOTO 999 CALL IPRINT(1) DO 220, IE=1,5 CALL ERRTST(NERR(IE),IERR) IF (IERR.EQ.1) GOTO 999 220 CONTINUE C IF (IWRITE(-1)) GOTO 999 GOTO 50 C 999 CONTINUE 997 CALL IPRINT(6) IE1=IE CALL ERRTXT(IE) IF (IERROR.EQ.3) GOTO 998 NE=NE+1 IF (NE.LT.10) GOTO 998 CALL IPRINT(12) NE=0 998 CALL RESET RES=RES0 IF (IE1.GE.6) GOTO 122 X=X0 IF (CHAR.EQ.'R') GOTO 122 IF (IE1.EQ.2.OR.IE1.EQ.4) IY=IY+1 GOTO 122 END FUNCTION IDECOD(I) C BYTE NUMBER(26),RES,CHAR,FMT(10),ROLUP(16),ROLDWN(12),HULP(28) BYTE ERR DOUBLE PRECISION X,Y(20) DIMENSION NERR(5) COMMON X,Y,IY,NUMBER,IN,HULP,IH,RES,CHAR,NERR,ICLR, * IERROR,IFMT,FMT,ROLUP,ROLDWN,ERR 1 FORMAT(F26.0) C IDECOD=0 C NULL=0 IF (IN.GT.1) GOTO 10 NUMBER(1)='0' IN=2 NULL=1 C 10 IF (RES) GOTO 20 IF (.NOT.ERR) IERROR=4 DECODE(IN-1,1,NUMBER,ERR=40) X C 20 IF (NULL.EQ.0) GOTO 30 IN=1 NUMBER(1)=0 30 IF (I.EQ.0) RETURN IF (.NOT.ERR) IERROR=3 IF (IY.GT.20) GOTO 40 Y(IY)=X RETURN C 40 IDECOD=-1 IF (I.EQ.1) IY=IY-1 RETURN END BYTE FUNCTION DFAC BYTE NUMBER(26),RES,CHAR,FMT(10),ROLUP(16),ROLDWN(12),HULP(28) BYTE ERR DOUBLE PRECISION X,Y(20) DIMENSION NERR(5) COMMON X,Y,IY,NUMBER,IN,HULP,IH,RES,CHAR,NERR,ICLR, * IERROR,IFMT,FMT,ROLUP,ROLDWN,ERR C DFAC=0 IF (X.LT. 0.) GOTO 999 IF (X.GT.33.) GOTO 999 N=IDINT(X) IF (FLOAT(N).NE.X) GOTO 999 X=1 IF (N.LE.1) RETURN DO 10, I=2,N 10 X=X*I RETURN 999 DFAC=-1 IF (.NOT.ERR) IERROR=8 RETURN END FUNCTION IWRITE(N) BYTE NUMBER(26),RES,CHAR,FMT(10),ROLUP(16),ROLDWN(12),HULP(28) BYTE ERR DOUBLE PRECISION X,Y(20),XH,DXH DIMENSION NERR(5) COMMON X,Y,IY,NUMBER,IN,HULP,IH,RES,CHAR,NERR,ICLR, * IERROR,IFMT,FMT,ROLUP,ROLDWN,ERR 1 FORMAT(I2) C IWRITE=0 IF (N.EQ.0) RETURN IF (N.GT.20) RETURN IF (N.EQ.-2) GOTO 50 C XH=X IF (N.GT.0) XH=Y(N) DXH=DABS(XH) C HULP(1)=' ' HULP(27)="200 IF (.NOT.ERR) IERROR=2 C IOFMT=IFMT ASSIGN 6 TO LBL IF (XH.EQ.0) GOTO 6 IF ((DXH.GE.(1D-1)).AND.(DXH.LT.(1D1**IFMT))) GOTO 6 IFMT=IFMT-1 C 4 ENCODE(2,1,FMT(8),ERR=999) IFMT IF (FMT(8).EQ.' ') FMT(8)='0' GOTO LBL C 6 ENCODE(25,FMT,HULP(2),ERR=999) DXH IF (IFMT.EQ.IOFMT) GOTO 8 IFMT=IOFMT ASSIGN 8 TO LBL GOTO 4 C 8 DO 10, IH=1,26 IF (HULP(IH).NE.' ') GOTO 20 10 CONTINUE C 20 IF (HULP(IH).NE.'0') GOTO 26 DO 24, J=IH,25 24 HULP(J)=HULP(J+1) HULP(26)=' ' C 26 IH=IH-1 IF (XH.LT.0D0) HULP(IH)='-' C 28 DO 30, J=26,1,-1 IF (HULP(J).NE.' ') GOTO 40 30 HULP(J)="200 40 CALL IPRINT(9) CALL PRINT(HULP(IH)) RETURN C 50 NUMBER(IN)="200 CALL PRINT(NUMBER) NUMBER(IN)=0 RETURN C 999 IWRITE=-1 RETURN END C SUBROUTINE PRLIST RETURN END SUBROUTINE OCTDEC(I) BYTE NUMBER(26),RES,CHAR,FMT(10),ROLUP(16),ROLDWN(12),HULP(28) BYTE ERR,XH(8) DOUBLE PRECISION X,Y(20) DIMENSION NERR(5) COMMON X,Y,IY,NUMBER,IN,HULP,IH,RES,CHAR,NERR,ICLR, * IERROR,IFMT,FMT,ROLUP,ROLDWN,ERR C 1 FORMAT(O6) 2 FORMAT(F7.0) C IF (I.NE.0) GOTO 100 C ENCODE(7,2,XH,ERR=900) X DECODE(6,1,XH,ERR=900) IXH X=IXH IF (X.LT.0D0) X=X+65536D0 RETURN C 100 IF (X.GT.32767D0) X=X-65536D0 ENCODE(6,1,XH,ERR=900) IDINT(X) DECODE(6,2,XH,ERR=900) X RETURN C 900 ERR=.TRUE. IERROR=4 RETURN END ! OCTDEC