SUBROUTINE BASCNG(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 + CALC VERSION X01-06 + C + + C ++++++++++++++++++++++++++++++++++++++++++++++++++ C C C C C ******************************************************* C * * C * SUBROUTINE BASCNG * C * * C ******************************************************* C C C SUBROUTINE BASCNG IS CALLED WHEN THE *B CALC COMMAND IS C ENCOUNTERED. THIS COMMAND INDICATES THAT THE DEFAULT BASE C FOR CONSTANTS IS TO BE CHANGED. THE ROUTINE READS IN ONE C OR TWO DIGITS AND CHANGES THE DEFAULT BASE SPECIFICATION C AS IS APPROPRIATE. C C C C MODIFICATION CLASS M2 C C C C C BASCNG CALLS C C ERRMSG (PRINTS ERROR MESSAGES) C GETNNB (GETS THE NEXT NON-BLANK IN INPUT LINE LINE(80)) C C C C C BASCNG IS CALLED BY ROUTINE CMND WHICH IDENTIFIES THE COMMAND THAT C THE USER WANTS TO EXECUTE. C C C C C C VARIABLE USE C C BASED HOLDS THE DEFAULT BASE. C IPT POINTS TO THE NEXT NON-BLANK IN LINE(80). C I1 BINARY VALUE OF FIRST DIGIT, VALUE OF NEW BASE. C I2 BINARY VALUE OF SECOND DIGIT. C NONBLK POINTS TO THE LAST NON-BLANK IN LINE(80) C RETCD RETURN CODE: 1=O.K. 2=ERROR. C RETCD2 HOLDS RETURN CODE FROM CALL TO GETNNB C C C C C SUBROUTINE BASCNG(RETCD) C C C UPON ENTRANCE, NONBLK POINTS TO THE 'B' IN '*B' IN LINE C INTEGER*2 IPT,I1,I2 INTEGER*2 LEVEL,NONBLK,LEND INTEGER*2 RETCD,RETCD2,VIEWSW,BASED C LOGICAL*1 DIGITS(16,3),LINE(80) C COMMON /DIGV/ DIGITS COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED C C C C C IF NO ARGUMENT, RETURN WITH NORMAL RETURN CODE. THIS ALLOWS THE C USER TO SEE WHAT THE PRESENT DEFAULT BASE IS. RETCD=1 CALL GETNNB(IPT,RETCD2) IF(RETCD2.GT.1)GO TO 1000 C C C CHECK OUT FIRST DIGIT DO 300 I1=1,10 IF(DIGITS(I1,1).EQ.LINE(IPT)) GO TO 400 300 CONTINUE GO TO 999 C C C SEE IF THERE IS A SECOND DIGIT 400 NONBLK=IPT IF(I1.EQ.10)I1=0 CALL GETNNB(IPT,RETCD2) IF(RETCD2.EQ.1)GO TO 500 C C C IF NOT, CONVERT TO A TWO DIGIT NUMBER WITH A LEADING ZERO. I2=I1 I1=0 GO TO 700 C C C C A SECOND CHARACTER WAS FOUND; FIGURE OUT WHAT THE BINARY C VALUE IS (IF IT IS A DIGIT AT ALL). 500 DO 600 I2=1,10 IF(DIGITS(I2,1).EQ.LINE(IPT))GO TO 700 600 CONTINUE GO TO 999 C C C C CONVERT DIGITS TO A NUMBER IF IT IS LEGAL 700 IF(I2.EQ.10)I2=0 I1=I1*10+I2 IF(I1.NE.8.AND.I1.NE.10.AND.I1.NE.16) GO TO 999 BASED=I1 GO TO 1000 C C C ILLEGAL BASE SPECIFICATION 999 RETCD=2 CALL ERRMSG(19) C C RETURN 1000 RETURN END