$ORIGIN=1400
$FILE=FILE2 
$EXTERNALS=MOVEL 1241,DECP 1257 
$EXTERNALS=XPACK 1262,NORML 1273,UNDOV 1311 
$EXTERNALS=EXPAK 1316,RNDOV 1326,UNFLO 1331 
$EXTERNALS=OVFLO 1333,XFER 1343,DXFER 1351
$EXTERNALS=GETQ1 1367,GETQD 1370,GETQX 1374 
**************   REVISION B      MAY 2,1974     ************* 
* CALLING SEQUENCE FOR DBLE ROUTINE2                 *
*                                                    *
* JSB DBLE                                           *
* DEF *&3                                            *
* DEF X %,ID                                         *
* DEF Y %,ID                                         *
*         ?RETURN                                    *
*                                                    *
* OPERATION2 CONVERT A 2-WORD Y TO A 3-WORD X.       *
*                                                    *
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* ROUTINE ACCESSES THE 2-WORD ARGUMENT, MASKS OFF T&E 
* EXPONENT, AND PUTS IT INTO A THIRD WORD OF ZEROS, 
* WITH THE VACATED EXPONENT SLOT ZERO FILLED.  THE
* GETAD SUBROUTINE WITHIN IT IS USED BY ALL OTHER 
* ROUTINES TO ACCESS THE ADDRESSES OF ANY DESIRED 
* ARGUMENT. 
* 
DBLE           JSB       GETQ1     GET ADR OF Y 
          S3   INC  P              P:=ADR OF DEF X
      F        JSB  S4   ULOD2     GET Y; SAVE F
      A        IOR  B              B:= HI 
      Q        IOR  A              A:=MID 
      F        CLO  Q              AVE EXP
      Q        LWF       L1        PUT EXP SIGN IN FLG
      Q        LWF  Q    L1        POSITION SIGN BIT
      Q   CR   AND  S1   377       MASK OUT LOW 
               JSB       GETQD     GET DEF X
          S4   SFLG F              RESTORE F
               JMP       DXFER     GO WRITE RESULT
***M***M***M***M***M***M***M***M***M***M***M***M***M**
*                                                    *
* 
*   PRIMARY JMP TABLE 
XNTRY     P    IOR  S3               ENTRY TO ROUTINES
               JSB       GETQ1     GET 1ST ADR FOR MOST ROUTINES
          ADR  IOR  S1
          S1   JMP       TBL3 
*    SECONDARY JUMP TABLE: START AT LOCATION 20(8)
TBL3           IOR
               JMP       DBLE 
               JMP       SNGL 
               JMP       XMPY 
               JMP       XDIV 
* 
* 
*  .DFER - TRANSFER ONE THREE WORD VARAB. TO ANOTHER
*     JSB .DFER 
*     DEF <TO ADR>
*     DEF <FROM ADR>
* 
.DFER     S3   IOR  P              P:=ADR OF FROM ADR 
      Q        JSB  A    GETQD     A:=FROM ADR; GET TO; 
      Q        IOR  B              B:=TO ADR; 
          P    INC  P              SET P FOR RETURN 
.XFER     CR   SFLG Q    3           MOVE 3 WORDS,NO INT. 
      B        JMP  S3   MOVEL     DO IT
* 
* NOTE :  LOCATION < TBL3 + 17(8); START XADD & XSUB; 
* 
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* CALLING SEQUENCE FOR ADD/SUBTRACT ROUTINE2         *
*                                                    *
* JSB XADD           AND         JSB XSUB            *
* DEF X %,ID                     DEF X U,I<          *
* DEF Y %,ID                     DEF Y U,I<          *
* DEF Z %,ID                     DEF Z U,I<          *
*                  XRETURN]                          *
*                                                    *
* OPERATION2 X 3 Y & Z           X 3 Y - Z           *
*                                                    *
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* FIRST ACCESS 0, T&EN Z.  IF SUBTRACTING, COMPLEMENT 
* Z AND THEN ADD. 
* 
XADD           SFLG 
XSUB           JSB       UNLOD     GET Y; SAVE P&F; 
SAVE  B        IOR  S1             S1:=HI MANT. 
      A        IOR  S2             S2:=MID MANT.
      Q        IOR  S3             S3:=LOW MANT.
      F        JSB  S4   GETQ1     S4:=EXP;  GET Z
*  NOTE: IF SAVE IS A SUBRUTINE, THE GETQ1 WILL RETURN  TO THE ORIGINAL CALLER..
* 
               JSB       ULOD3     GET Z
      Q        CFLG P    RSS  FLG  SAV Z LO MANT: IF
               JMP       SWICH      ADDING CONTINUE 
COMP  B        NOR  B              ELSE COMPLEMENT
      A        NOR  A                ARGUMENT 
          P    SUB  Q    RSS  COUT IF LO MANT#0 
      A        INC  A         TBZ   INC MID MANT
               JMP       SWICH       ELSE CONTINUE
      B        INC  B    RSS  NEG  IF MID=0,INC HI
*                                  IF HI POS CONTINUE;
      B        IOR       L1   TBZ  IF HI NOT EQ 100000
               JMP       SWICH      CONTINUE, ELSE
      B        IOR  B    R1        MAKE HI#040000 
      F        INC  F              ADD 1 TO EXPONENT
SWICH          RSB                 RETURN IF SUBROUTIN
* 
* T&E FIRST 0 ARGUMENT FORCES AN EXIT WITH THE OTHER
* ARGUMENT AS T&E RESULT.  FIND EXPONENT DIFFERENCET
* AND FORCE NUMBER WITH THE LARGER EXPONENT INTO
* S1, S2, S3, AND S4.  THE EXPONENT OF THIS NUMBER
* %S4< IS T&E EXPONENT OF T&E RESULT BEFORE NORMAL- 
* IZATION.
* 
      B        CLO       RSS  TBZ  IF Z30, EXIT WIT&
               JMP       OUT        Y.
          S1   IOR       RSS  TBZ  IF Y30, EXIT WIT&
               JMP       XPACK      Z.
      F   S4   SUB  P    RSS  NEG  IF EXP Y ] EXP Z 
               JMP       ADDEM      ALIGN POINTS, ELSE
      F        IOR  S4             SAVE EXP OF
          P    IOR  F               RESULT IN S4, PUT 
      B        IOR  P                POSITIVE EXPON 
OUT2      S1   IOR  B                  DIFFERENCE IN P
          P    IOR  S1                 AND EXCHANGE 
      A        IOR  P                   THE ARGUMENTS 
          S2   IOR  A 
          P    IOR  S2
      Q        IOR  P 
          S3   RSB  Q 
          P    IOR  S3        UNC 
* 
* ALIGN THE BINARY POINTS, AFTER INSURING T&AT THE
* EXPONENT DIFFERENCE IS NOT GREATER THAN 40.  IF NOT,
* ADD T&E ARGUMENTS AND EXIT TO XPACK FOR NORMALIZING,
* ROUNDING, AND PACKINGC  IF GREATER THAN 40, EXIT TO 
* XPACK VIA OUT WIT& THE ARGUMENT HAVING THE LARGER 
* EXPONENT UALGEBRAICALLY<. 
* 
ADDEM     P    SUB  F              MAKE EXP DIFF POS
          CR   IOR  P    51        IF EXPON DIFFERENCE
      F   P    SUB            NEG  GREATER THAN 40
               JMP       OUT       EXIT 
               CJMP      XINT        (IF INTRRUPT THEN ...;)
      F        NOR  P              ELSE 
               JMP       SHIFT      ALIGN 
      A        LWF       R1          DECIMAL
      B        ARS  B    R1           POINTS
      Q        LWF  Q    R1            AND
SHIFT     P    INC  P         TBZ       PROCEED TO
               JMP       *-4             ADD NOC S
      Q   S3   ADD  Q         COUT ADD ARGUMENTS AND
               JMP       *+5        CARRY FROM
      A   S2   INC  A         COUT   ONE WORD 
               JMP       *+5          TO NEXT 
      B   S1   INCO B 
               JMP       *+4
      A   S2   ADD  A    RSS  COUT
               JMP       *-3
      B   S1   ADDO B 
          S4   CLO  F         OVF  DID RESULT OVERFLOW
               JMP       XPACK     NO, GO NORMALIZE 
      B        CFLG           NEG  0ES. IF RESULT NEG 
               SFLG                 COUT WAS POS. IF
      B        LWF  B    R1          RESULT POST COUT 
      A        LWF  A    R1           WAS NEG. SHIFT
      Q        LWF  Q    R1            COUT TO RESULT 
      F        INC  F                   AND INC EXP 
               JMP       XPACK     GO NORMALIZE RESULT
OUT       S4   IOR  F              EXIT WITH ARGUMENT 
               JSB       OUT2         WITH LARGER 
               JMP       XPACK         EXPONENT ; 
***M***M***M***M***M***M***M***M***M***M***M***M***M**
*                                                    *
* 
* CALLING SEQUENCE FOR SNGL ROUTINE2                 *
*                                                    *
* JSB SNGL                                           *
* DEF *&2                                            *
* DEF Y %,ID                                         *
*         ?RETURN                                    *
*                                                    *
* OPERATION2 ROUND A 3-WORD Y TO A 2-WORD RESULT     *
*            IN THE A-B REGISTERS.                   *
*                                                    *
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* ACCESS THE 3-WORD ARGUMENT %YD, AND ROUND TO 1 1/2
* WORDSC
* 
SNGL  F        JSB  S4   ULOD3     GET ARG
          CR   CLO  S3   177       SET UP FOR ROUNDING
      B        IOR  S1   RSS  NEG  IF ARG POS, ROUND MID
      Q        IOR            TBZ  IF NEG, FAKE ROUND LO
          CR   IOR  S3   200         AND DO ROUND MID 
      A   S3   ADD  A    RSS  COUT
      B        INCO B              EXTEND CARRY TO HI 
      A   CL   AND  A    377       MASK OUT THE JUNK
               CLO       RSS  OVF  IF OVFLO FROM ROUND
               JSB       RNDOV     THEN RENORMALIZE 
      A   S1   IOR            TBZ  IF ARG=A0 DONT NORMALIZE 
               JSB  Q    NORML     GO NORMALIXE ARG 
          CR   IOR  S3   200       IF EXP<-200B 
      F   S3   ADD       RSS  NEG 
               JMP  B    SNUNF        THEN EXP UNDERFLO 
      F   S3   SUB            NEG  IF EXP>177B
               JMP       SNOVF        THEN OVFLO
      A        JSB  S1   EXPAK     PACK IN EXPONENT 
      B        IOR  A              PUT ANS IN THE A,B-REG 
      Q        IOR  B 
EXIT      S4   IOR  F         EOP  RESTORE F
          P    INC  P              INC TO RETURN, EXIT
* 
SNOVF          NOR  B    L1        IF OVFLO RETURN INFINITY 
SNUNF B        SOV  A    R1        IF UNFLO RETURN ZERO 
               JMP       EXIT 
***M***M***M***M***M***M***M***M***M***M***M***M***M**
*                                                    *
* 
* CALLING SEQUENCE FOR XMPY ROUTINE2                 *
*                                                    *
* JSB XMPY                                           *
* DEF X %,ID                                         *
* DEF Y %,ID                                         *
* DEF Z %,ID                                         *
*         ?RETURN                                    *
*                                                    *
* OPERATION2 X 3 Y M Z                               *
*                                                    *
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* ACCESS ARGUMENTS, COMPLEMENT THEM IF NEGATIVET AND
* SAVE SIGN OF RESULT IN OVF.  COMPUTE EXPONENT X AS: 
* EXP Y & EXP Z %OR EXP I< & 1.  DVMPY IS ENTRY POINT 
* FROM XDIV ROUTINEC
* 
XMPY           JSB       UNLOD     GET Y
      B        CLO            NEG  SAVE SIGN OF Y IN OVF
               JMP       XMPY1
          P    SOV  S1             IF NEG COMPLEMENT Y
      Q        JSB  P    COMP 
          S1   IOR  P              RESTORE P
XMPY1 Q        JSB  S3   SAVE      SAVE Y; GET Z ADR; 
               JSB       ULOD3     GO ACCESS Z
DVMPY B        IOR            NEG  IF Z POSITIVE
               JMP       MULT       CONTINUE, ELSE
               CLO            OVF  WAS 0 NEGATIVE 
               SOV                 NO, PUT SIGN IN OVF
      Q        JSB  P    COMP      COMPLEMENT Z 
* 
* COMPUTE 3 CROSS-PRODUCTS LO Z * HI Y, HI Z * LO YT
* MID Z * MID YT ADD THEM, AND PROPOGATE AN0 CARRIES
* TO WHAT WILL BE T&E MID X MANTISSA.  SAVE ONL0 THE
* HI WORD OF THIS SUM, AND USE THE LO WORD TO INDICATE
* W&ETHER TO ROUND AT T&IS POINT. 
* 
MULT  F   S4   INC  F              ADD EXPONENTS
      F        CJMP S4   XINT       AND INC EXP X B0 1
      A        IOR  F              SAVE MID Z MANTISSA
      Q        IOR  A              SET LOW Z TO MULTPY
      B        IOR  Q              SAVE HI Z MANTISSA 
               IOR  B    CNTR RPT  MULTIPLY LO Z
      B   S1   MPY  B    R1   CTRI  BY &I Y 
      B        IOR  P              SAVE LEFT PROD IN P
      A        IOR  B              PUT RITE PROD IN B 
      Q        IOR  A    CNTR RPT  SET &I Z TO MULTPY 
      B   S3   MPY  B    R1   CTRI MULT HI Z BY LO 0
      B   P    ADD  P              ADD 2 LEFT PRODUCTS
      A        IOR  B              PUT RITE SUM IN B
      F        IOR  A    CNTR RPT  SET MID Z TO MULTPY
      B   S2   MPY  B    R1   CTRI MULT MID Z B0 MID Y
               IOR  S3             CLEAR S3 
      B   P    ADD  B    RSS  COUT ADD 3 LEFT PRODUCTS
               INC  S3             IF COUT,SET S3 TO 1
      A        IOR       RSS  NEG  IF RITE 3 SUM NEG
      B        INC  B         COUT  ROUND LEFT SUM AND
          S3   IOR  P         UNC    PUT NEW LEFT WORD
          S3   INC  P              ULO OF XD IN P 
* 
* COMPUTE 2 CROS-PRODUCTS HI Z M MID Y, MID Z * HI 0, 
* AND ADD T&EM.  ADD THE HI WORD OF THE FIRST CROSS-
* PRODUCTS SUM TO T&E LO WORD OF THIS CROSS-PRODUCTS
* SUM, 0IELDING THE FINAL LO X MANTISSA AND THE 
* PARTIAL MID X MANTISSA.  PROPOGATE ALL CARRIES TO 
* W&AT WILL BE THE &I X MANTISSA. 
* 
      Q        IOR  A    CNTR RPT  SET &I Z TO MULTPY 
      B   S2   MPY  B    R1   CTRI MULT HI Z BY MID Y 
      B   P    ADD  S3        COUT ADD 2 LEFT WORDS & 
               IOR  P         UNC  PUT NEW MID TO S3
               INC  P              & SET P TO BE HI X 
      A        IOR  B              PUT NEW LO X IN B
      F        IOR  A    CNTR RPT  SET MID Z TO MULTY 
      B   S1   MPY  B    R1   CTRI MULT MID Z B0 HI Y 
      A        IOR  S2             SAV END LO X IN S2 
      B   S3   ADD  B    RSS  COUT PUT NEW MID X IN B 
          P    INC  P              IF COUT INC &I X 
* 
* COMPUTE FINAL CROSS-PRODUCT HI Z M HI Y.  ADD THE LO
* WORD OF T&IS SUM TO T&E HI WORD OF THE PREVIOUS SUM,
* PROPOGATING ANY CARRIES TO THE HI WORD OF THIS
* CROSS-PRODUCTC  T&IS 0IELDS T&E FINAL HI AND MID X. 
* 
      Q        IOR  A    CNTR RPT  SET &I Z TO MULTPY 
      B   S1   MPY  B    R1   CTRI MULT HI Z BY HI 0
      B   P    ADD  B              ADD FOR END &I X 
          S2   IOR  Q              SAVE LO X IN Q 
          S4   CLO  F    RSS  OVF  IF X TO BE NEG 
      Q        JSB  P    COMP       COMPLEMENT X,ELSE 
               JMP       XPACK     GO NORMALIZE 
***M***M***M***M***M***M***M***M***M***M***M***M***M**
*                                                    *
* 
* CALLING SEQUENCE FOR XDIV ROUTINE2                 *
*                                                    *
* JSB XDIV                                           *
* DEF X %,ID                                         *
* DEF Y %,ID                                         *
* DEF Z %,ID                                         *
*         ?RETURN                                    *
*                                                    *
* OPERATION2 X 3 Y / Z                               *
*                                                    *
***M***M***M***M***M***M***M***M***M***M***M***M***M**
* 
* ACCESS Z, SAVE ITS SIGN IN OVF, AND IF NEGATIVE,
* COMPLEMENT ITC
* IF MID AND LO Z ARE NOT BOTH ZEROT COMPUTE EXPONENT 
* I AS -%EXPONENT ZD & 1.  IF T&EY ARE, THEN COMPUTE
* EXPONENT I AS -%EXPONENT Z< & 2 AND PROCEED TO SPCAS
* TO COMPUTE THE SHORTCUT INVERSE.
* 
XDIV      S3   IOR  S1
               JSB       GETQ1     GET Z ADR; 
               JSB       UNLOD     GET Z; 
      B        SOV            NEG  SAVE SIGN OF Z IN
               CLO            UNC   OVF AND COMPLEMENT
      Q        JSB  P    COMP        Z IF Z NEGATIVE
      F        DEC  S4             EXP I # -EXP Z & 1 
          S4   SUB  S3
      B        SFLG S2   RSS  TBZ  IF DIVISION BY 0 
               JMP       DVZRO      EXIT, ELSE
      A        CFLG      RSS  TBZ  IF LO,MID NOT BOTH 
      Q        IOR            TBZ  0 FIND REGULAR 
               JMP       *+4          INVERSE, ELSE 
          CL   IOR  F    40        SET &I U3020000
          S3   INC  S4             EXP I # EXP I & 1
               JMP  P    SPCAS     GET SHORTCUT INVERS
          S3   IOR  S4             SAVE EXP I 
* 
* COMPUTE: 1< 1/2"2N16Z2&Z3S/Z1 # 2-1&S1/Z1 
*          2< Q1)2 3 2)16P1&P2
*          3< 2N16S1/Z1 # 2-2&S2/Z1 
*          4< 4P1 # 2)16P11&P12 
*          5< -U2)16Q1&-2< 3 2)16U21&U31
*          6< 2N16U21&U31&2N16P11&P12 # 2)16U2&U3 
*          7< 2N%14-1< 3 2)32U1 
* 
      A        LWF  F    R1        RIGHT SHIFT LO,
      Q        LWF  Q    R1         MID Z 
               IOR  B    CNTR RPT  DIVIDE B0 HI Z:
      F   S2   DIV  F    L1   CTRI   #Q1
      Q        IOR  S3             SAVE Q1
      Q        IOR  A    CNTR RPT  GET -1 ) 2: 3P1
      B   S3   MPY  B    R1   CTRI
               CFLG Q    CNTR RPT  DIVIDE B0 HI Z:
      F   S2   DIV  F    L1   CTRI   #Q2
          S3   NOR  F              COMPLEMENT 
      Q        NOR  Q               Q1
      Q        INC  Q    RSS  COUT   AND
      F        INC  F                 Q2
      B        LWF  B    L1        LEFT 
               LWF  P    L1         SHIFT 
      B        LWF  B    L1           P1
          P    LWF  P    L1            TWICE
      B        IOR  S3             AD T&IS TO -UQ1,-2<
      Q   S3   ADD  Q         COUT  YIELDING MID U
      F   P    ADD  A         UNC    %SAVED IN A< AND 
      F   P    INC  A                 LO U USAVED 
      Q        IOR  P                  IN PD
          CL   IOR  F    77        SET &I U EQUAL TO
      F   CR   IOR  F    377        037777
* 
* COMPUTE T&E DESIRED RESULT I 3 "2N32U1&2)16U2&U3\/Z1
* 
SPCAS A        IOR  Q    CNTR RPT  SET MID U TO DIVIDE
      F   S2   DIV  F    L1   CTRI DIVIDE B0 HI Z TO
      Q        IOR  B              GIVE HI I:SAV IN B 
          P    IOR  Q              SET LO U TO DIVIDE 
               IOR  A    CNTR RPT  DIVIDE B0 HI Z TO
      F   S2   DIV  F    L1   CTRI  GIVE MID I AND
      Q        IOR  A                SAVE IN A
               IOR  Q    CNTR RPT  DIVIDE B0 HI Z TO
      F   S2   DIV  F    L1   CTRI  GIVE LO I 
          S4   IOR  F              RESTORE EXP I
               JSB       NORML     GO NORMALIZE I 
* 
* GET NUMERATOR %Y<T AND IF NO DIVISION BY 0, GO
* MULTIPLY TO GET T&E FINAL RESULT X. 
* 
DVZRO     S1   IOR  P              SET P TO GET Y ADR 
      Q        JSB  S3   SAVE      SAVE INVERSE 
               JSB       ULOD3     GO ACCESS Y
               IOR       RSS  FLG  IF DIVISION BY 0 
               JMP       OVFLO      GO TO OVFLOT ELSE 
               JMP       DVMPY     GO GET X3Y*I 
* 
* 
* UNLOD SUBROUTINE ACCESSES AND UNPACKS 2 OR 3-WORD 
* ARGUMENTST SAVES THE FENCE ADDRESS IN LOCATION 0, 
* AND SAVES THE ADDRESS OF THE DEF X OF THE CALLING 
* SEQUENCE IN LOCATION 1.  IF ENTERING AT UNLOD 
* F AND THE DEF X ADDRESS ARE SAVEDC  IF AT ULOD3, A
* 3-WORD ARGUMENT IS ACCESSED, WITH HI IN BT MID IN A,
* LO IN Q, AND EXP IN FC  IF AT ULOD2, A 2-WORD 
* ARGUMENT IS ACCESSED, WIT& HI IN A, LO IN Q, AND
* EXP IN F. 
* 
UNLOD          IOR  M    CW   UNC  (0) := FENCE REG.
               IOR
      F   RRS  IOR  T 
               INC  S2             (1):=ADR OF DEF X
          S2   IOR  M    CW   UNC 
               IOR
          S3   IOR  T 
ULOD3 Q   RRS  IOR  M    RW        B:=HI MANTISSA 
      Q        INC  Q 
          T    IOR  B 
ULOD2 Q   RRS  IOR  M    RW        A:=MID MANTISSA
      Q        INC  Q 
      AAB COND IOR  A 
      Q   RRS  IOR  M    RW        F:=LOW & EXP 
      AAB COND IOR  F 
      F   CL   AND  Q    377       Q:=LOW MANTISSA
      F   CR   AND  F    377       F:=EXP 
      F        IOR  F    R1   ODD  SHIFT OFF EXP SIGN 
               RSB                 IF EXP POS THEN RETURN 
      F   CR   SUB  F    200       ELSE EXTEND SIGN 
               RSB                      AND RETURN
* 
* 
XINT           JSB       XFER      EXIT; RETURN AFTER 
               JMP       DECP         INTERRUPT IS OVER;
* 
$END