SUBROUTINE MULDIV (PT1,PT2,RETCD,BASE) 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 * SUBROUTINE MULDIV (PT1,PT2,RETCD,BASE) * C * * C ************************************************** C C C SUBROUTINE MULDIV PERFORMS MULTIPLE PRECISION DIVISION C C C C ARGUMENTS: (PT1,PT2,RETCD) C C PLACES STACK1( ,PT1)/STACK2( ,PT2) INTO STACK1( ,PT1) C C STACK 2 IS NOT CLEANED UP BY THIS ROUTINE C C ERROR RETURN 1 = NORMAL C 2 = ERROR C C C C ENTRY INDICATES THE BASE: 8, 10, OR 16 C C C C C MODIFY CODES: M3, M10 C C C C C MULDIV CALLS ERRMSG TO PRINT ERROR MESSAGES. C C C C C MULDIV IS CALLED BY CALBIN C C C C C VARIABLE USE C C ANSWER HOLDS QUOTIENT C BASE HOLDS THE BASE: 8, 10, OR 16 C CARRY USED TO "BORROW" WHEN SUBTRACTING C DIVPT POINTS TO HIGHEST (NON-ZERO) DIGIT OF DIVISOR. C I,M,K,L TEMPORARY VALUES. C NPT HOLDS POSITION OF HIGHEST (NON-ZERO) DIGIT OF DIVIDEND. C PT1 POINTER TO STACK1 ELEMENT (DIVIDEND) C PT2 POINTER TO STACK2 ELEMENT (DIVISOR) C RETCD RETURN CODE: 1=O.K., 2=ERROR. C C C C C C C SUBROUTINE MULDIV (PT1,PT2,RETCD,BASE) INTEGER*2 RETCD,BASE,DIVPT,NPT,CARRY INTEGER*2 ST1PT,ST2PT,ST1LIM,ST2LIM,PT1,PT2 INTEGER*2 ST1TYP(40),ST2TYP(40) INTEGER*2 I,M,K,L C LOGICAL*1 ANSWER(100) LOGICAL*1 STACK1(100,40),STACK2(100,40) C COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP, ; ST1LIM,ST2LIM C C C C C C SET DEFAULT RETURN CODE AND ZERO ANSWER RETCD=1 DO 110 I=1,100 110 ANSWER(I)=0 C C C DETERMINE SIGN OF ANSWER IF (STACK1(100,PT1)+STACK2(100,PT2).EQ.1)ANSWER(100)=1 C C C FIND HIGH ORDER NON-ZERO DIGIT OF DIVISOR (HELD BY DIVPT) DO 140 I=1,99 DIVPT=100-I IF (STACK2(DIVPT,PT2).NE.0) GOTO 150 140 CONTINUE C C C DIVISOR IS ZERO, PRINT OUT APPROPRIATE ERROR MESSAGE RETCD=2 CALL ERRMSG (23) RETURN C C C FIND STARTING NON-ZERO DIGIT OF DIVIDEND (HELD BY NPT) 150 DO 170 I=1,99 NPT=100-I IF (STACK1(NPT,PT1).NE.0) GOTO 200 170 CONTINUE C C C ANSWER IS ZERO GOTO 10000 C C C C C C ************************************************ C ****** FIND OUT WHERE TO SUBTRACT DIVISOR ****** C ************************************************ C (NEXT LINE WAS $200 IF ...) 200 IF (NPT.LT.DIVPT) GOTO 10000 C C M POINTS TO A DIGIT OF DIVIDEND ALIGNED WITH THE LOW ORDER DIGIT OF C DIVISOR. M=NPT-DIVPT+1 C C K INDEXES DIVIDEND FROM HIGH ORDER END. K=NPT C C L INDEXES DIVISOR FROM HIGH ORDER END. L=DIVPT DO 250 I=1,DIVPT IF (STACK2(L,PT2).EQ.STACK1(K,PT1)) GOTO 240 C C WHEN COMPARING DIGITS OF DIVISOR AND DIVIDEND, IF THE DIVISOR'S C DIGIT IS SMALLER AND ALL PREVIOUS WERE EQUAL, C THEN WE GO TO 300 TO SUBTRACT OFF THE DIVISOR. IF (STACK2(L,PT2).LT.STACK1(K,PT1)) GOTO 300 C C OTHERWISE THOSE DIGITS OF THE DIVIDEND REPRESENT A LARGER C NUMBER. IF THE NUMBER OF DIGITS OF THE DIVISOR IS GREATER C THAN OR EQUAL TO DIVIDEND THEN THE QUOTIENT IS 0 AND THE C REMAINDER IS THE DIVIDEND. (GO TO 10000) IF (NPT.LT.DIVPT+1) GOTO 10000 C C OTHERWISE SHIFT THE POSITION OF THE DIVISOR BY 1. M=M-1 GOTO 300 C C C K INDEXES DIVIDEND C L INDEXES DIVISOR 240 K=K-1 L=L-1 250 CONTINUE C C C C C ************************************** C ****** SUBTRACT OFF THE DIVISOR ****** C ************************************** 300 CONTINUE C C K POINTS TO LOW ORDER DIGIT WHERE SUBTRACTION TAKES PLACE, C CARRY TAKES CARE OF "BORROWS" K=M-1 CARRY=0 DO 350 I=1,DIVPT K=K+1 L=STACK1(K,PT1)-STACK2(I,PT2)-CARRY IF (L.GE.0) GOTO 325 C C IF SUBTRACTION RESULTS IN A "NEGATIVE DIGIT", ADD BASE AND SET CARRY C INDICATOR. CARRY=1 L=BASE+L GOTO 340 C C RESULT OF SUBTRACTION IS A POSITIVE NUMBER, SO C CLEAR CARRY INDICATOR. 325 CARRY=0 340 STACK1(K,PT1)=L 350 CONTINUE IF(CARRY.EQ.1) STACK1(K+1,PT1)=STACK1(K+1,PT1)-1 C C C THE QUOTIENT (ANSWER(M)) COUNTS THE NUMBER OF SUBTRACTIONS. ANSWER(M)=ANSWER(M)+1 C C C RESET THE POINTER TO THE HIGH ORDER NON-ZERO DIGIT OF THE C DIVIDEND IF NECESSARY. 370 IF (STACK1(NPT,PT1).NE.0) GOTO 200 NPT=NPT-1 IF (NPT.EQ.0) GOTO 10000 GOTO 370 C C C C C *************************** C ****** COPY ANSWER ****** C *************************** 10000 DO 10010 I=1,100 10010 STACK1(I,PT1)=ANSWER(I) RETURN END