Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/mulcon.for
There is 1 other file named mulcon.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 * SUBROUTINE MULCON (STACK,INDEX,OLDA,NEWA,RETCD) *
C * *
C ****************************************************
C
C
C
C WHICH CONVERTS MULTIPLE PRECISION NUMBER IN STACK ( ,INDEX) FROM
C BASE "OLD" TO BASE "NEW".
C
C ERROR RETURN: RETCD VALUE MEANING
C 1 O.K.
C 2 ERROR
C
C LEGAL VALUE FOR OLDA AND NEWA: 5 (BASE 8), 6 (BASE 10), 7 (BASE 16)
C
C
C
C MODIFY CODES: M3, M10
C
C
C
C MULCON IS CALLED BY CONTYP
C
C
C
C
C
C
C VARIABLE USE
C
C ANSWER(100) HOLDS ANSWER.
C APT POINTER FOR VECTOR ANS (WHICH HOLDS ANSWER).
C BCON VECTOR OF LEGAL BASES (8, 10, AND 16).
C CARRY USED TO "BORROW" WHEN SUBTRACTING OFF DIVISOR.
C DIVPT POINTER FOR THE DIVISOR (A VECTOR)
C I,M,K,L TEMPORARY VALUES.
C INDEX POINTER TO NUMBER (IN STACK) TO BE CONVERTED.
C ISW SWITCH: 0=ONLY DIGITS 0 FOUND, 1=NON-ZERO FOUND.
C NEW NEW BASE: 8, 10, OR 16.
C NEWA NEW BASE CODE: 5,6 OR 7
C NPT POINTER TO HIGH ORDER DIGIT OF NUMBER AS IT IS SUCCESSIVELY
C REDUCED BY DIVISION.
C NPTH HOLDS OLD NPT VALUE.
C OLD OLD BASE: 8, 10, OR 16
C OLDA OLD BASE CODE: 5,6, OR 7
C QUOT(100) HOLDS QUOTIENT FOR SUCCESSIVE DIVIDES.
C RETCD RETURN CODE: 1=O.K., 2=ERROR.
C STACK(,INDEX) HOLDS MULTIPLE PRECISION NUMBER TO BE CONVERTED.
C
C
C
C
C
C
SUBROUTINE MULCON (STACK,INDEX,OLDA,NEWA,RETCD)
C
INTEGER*2 OLD,NEW,RETCD,DIVPT,NPT,APT,BCON(3)
INTEGER*2 CARRY,NPTH,NEWA,OLDA
INTEGER*2 I,M,K,L
C
C
LOGICAL*1 STACK(100,40),QUOT(100),ANSWER(100),DIV(2)
C
C
DATA BCON/10,8,16/
C
RETCD=1
IF (OLDA.EQ.NEWA) RETURN
OLD=BCON(OLDA-4)
NEW=BCON(NEWA-4)
IF (OLD.NE.16) GOTO 100
C
C
C
C
C
C ***********************************************************
C ******** SET UP DIVISOR (DIV(1), DIV(2)) ACCORDING ********
C ******** TO OLD AND NEW BASES. ********
C ***********************************************************
C OLD IS BASE 16, NEW CAN BE ANYTHING
C ALSO ENTER HERE IF OLD IS BASE 10 AND NEW BASE IS 8
90 DIV(1)=NEW
DIV(2)=0
GOTO 1000
100 IF (OLD.NE.10) GOTO 200
C
C
C OLD IS BASE 10
IF (NEW.EQ.8) GOTO 90
C
C
C OLD IS BASE 10, NEW IS BASE 16
DIV(1)=6
DIV(2)=1
GOTO 1000
C
C
C OLD IS BASE 8
200 IF (OLD.NE.8) STOP 200
IF (NEW.EQ.10) GOTO 250
C
C
C NEW IS BASE 16, OLD IS BASE 8
DIV(1)=0
DIV(2)=2
GOTO 1000
C
C
C NEW IS BASE 10, OLD IS BASE 8
250 DIV(1)=2
DIV(2)=1
C
C
C
C
C
C
C
C
C **********************************************************
C ****** CONVERT TO NEW BASE BY SUCCESSIVELY DIVIDING ******
C ****** BY THE NEW BASE (AS EXPRESSED IN THE OLD ******
C ****** BASE) TO GET REMAINDERS. ******
C **********************************************************
1000 CONTINUE
APT=1
C
C
C ZERO OUT ANSWER AND QUOTIENT
DO 1010 I=1,99
QUOT(I)=0
1010 ANSWER(I)=0
C
C
C FIND HIGH ORDER NON-ZERO DIGIT OF DIVISOR
DIVPT=1
IF (DIV(2).NE.0) DIVPT=2
C
C
C FIND HIGH ORDER NON-ZERO DIGIT OF NUMBER TO BE CONVERTED
DO 1100 I=1,99
NPTH=100-I
IF (STACK(NPTH,INDEX).NE.0) GOTO 1195
1100 CONTINUE
C
C
C NUMBER IS 0 SO SIMPLY RETURN
RETURN
C
C
C
C
C
C
C ***********************************
C ****** CALCULATE REMAINDERS ******
C ***********************************
C
C FIRST DETERMINE WHERE TO SUBTRACT
1195 NPT=NPTH
1200 CONTINUE
C
C IF DIVISOR IS LESS THAN DIVIDEND, THE REMAINDER IS THE DIVIDEND
C SO GO TO 10000
IF (NPT.LT.DIVPT) GOTO 10000
C
C M POINTS TO THE DIGIT OF THE DIVIDEND ALIGNED BY THE LOW ORDER
C DIGIT OF THE DIVISOR WHEN DIVIDEND AND DIVISOR HAVE THEIR HIGH
C ORDER DIGITS ALIGNED.
M=NPT-DIVPT+1
C
C K INDEXES DIGITS OF DIVIDEND FROM HIGH ORDER END.
K=NPT
C
C L INDEXES DIGITS OF DIVISOR FROM HIGH ORDER END.
L=DIVPT
DO 1250 I=1,DIVPT
IF (DIV(L).EQ.STACK(K,INDEX)) GOTO 1240
C
C IF DIGIT OF DIVISOR IS LESS THAN CORRESPONDING DIGIT OF DIVIDEND
C WE CAN SUBTRACT OFF THE DIVISOR FROM THE APPROPRIATE DIGITS OF
C DIVIDEND.
IF (DIV(L).LT.STACK(K,INDEX)) GOTO 1300
C
C IF DIVISOR AND DIVIDEND HAVE THE SAME NUMBER OF DIGITS AND AS
C THE DIGITS ARE COMPARED FROM THE HIGH ORDER END, DIGITS ARE
C EQUAL UNTIL A DIGIT OF DIVISOR IS GREATER, THEN THE DIVISOR
C IS GREATER THAN THE DIVIDEND SO REMAINDER IS JUST THE DIVIDEND
C AND WE GO TO 10000.
IF (NPT.LT.DIVPT+1) GOTO 10000
C
C THE SIZE OF THE HIGH ORDER DIGITS OF THE DIVIDEND ARE SUCH THAT WE WILL
C BE SUBTRACTING THE DIVISOR AFTER SHIFTING ALIGNMENT ONE PLACE TO THE
C RIGHT (WHEN HIGH ORDER DIGITS WERE ALIGNED, THE CORRESPONDING DIGITS
C OF THE DIVIDEND FORMED A NUMBER THAT WAS TOO SMALL).
M=M-1
GOTO 1300
C
C
C K IS DIVIDEND POINTER
C L IS DIVISOR POINTER
1240 K=K-1
L=L-1
1250 CONTINUE
C
C
C
C
C **********************************************************
C ****** DIVISION PERFORMED BY SUCCESSIVE SUBTRACTION ******
C **********************************************************
1300 CONTINUE
K=M-1
CARRY=0
DO 1350 I=1,DIVPT
K=K+1
L=STACK(K,INDEX)-DIV(I)-CARRY
IF (L.GE.0) GOTO 1325
CARRY=1
L=OLD+L
GOTO 1340
1325 CARRY=0
1340 STACK(K,INDEX)=L
1350 CONTINUE
IF(CARRY.EQ.1) STACK(K+1,INDEX)=STACK(K+1,INDEX)-1
C
C THE QUOTIENT IS JUST HOW MANY SUBTRACTIONS WHERE MADE
QUOT(M)=QUOT(M)+1
C
C NPT IS ADJUSTED (IF NECESSARY) TO POINT TO HIGHEST NON-ZERO
C DIGIT OF DIVIDEND.
1370 IF (STACK(NPT,INDEX).NE.0) GOTO 1200
NPT=NPT-1
IF (NPT.EQ.0) GOTO 10000
GOTO 1370
C
C DIGIT OF ANSWER IS JUST THE REMAINDER. NOTE THAT THIS DIGIT IS LESS
C THAN THE BASE.
10000 ANSWER(APT)=OLD*STACK(2,INDEX)+STACK(1,INDEX)
C
C
C ADJUST ANSWER POINTER.
APT=APT+1
C
C
C
C
C *******************************************************
C ****** COPY QUOTIENT BACK INTO STACK TO FORM NEW ******
C ****** DIVIDEND AND ZERO OUT QUOTIENT VECTOR. ******
C *******************************************************
ISW=0
DO 10100 I=1,99
K=QUOT(I)
IF (K.NE.0) ISW=1
QUOT(I)=0
10100 STACK(I,INDEX)=K
C
C
C
C CALCULATE NEW VALUE FOR NPTH (POINTER TO HIGHEST NON-ZERO DIGIT
C OF DIVIDEND.
IF (ISW.EQ.0) GOTO 10500
10150 IF (STACK(NPTH,INDEX).NE.0) GOTO 1195
NPTH=NPTH-1
GOTO 10150
C
C
C
C REPLACE OLD NUMBER WITH THE VALUE AS EXPRESSED IN NEW BASE.
10500 DO 10550 I=1,99
10550 STACK(I,INDEX)=ANSWER(I)
C
C
RETURN
END