* STORE BINARY ACCUMULATOR                              HEADER  C:BSTO  0001.000
*                                                                       0002.000
*              STORE BINARY ACCUMULATOR                                 0003.000
*                                                                       0004.000
         M.PGM     C:BSTO,MPX-32,3.6.1,00                               0005.000
         DEF   C:BSTO,CR.BSTO                                           0006.000
*                                                                       0007.000
* STORE BINARY ACCUMULATOR                                              0008.000
*    ARG1 - ACCUMULATOR TO BE STORED                                    0009.000
*    ARG2 - DD FOR DESTINATION                                          0010.000
*                                                                       0011.000
         EXT   CR.SBVAL                                                 0012.000
         EXT   CR.LBVAL                                                 0013.000
         EXT   CR.LSCL                                                  0014.000
         EXT   CR.RSCL                                                  0015.000
         EXT   CR.BLD                                                   0016.000
         M.REQS                                                         0017.000
         DD.EQU                                                         0018.000
         COBOLDAT                                                       0019.000
*                                                                       0020.000
* INTERNAL DATA                                                         0021.000
*                                                                       0022.000
         ORG   WORKAREA+8D                                              0023.000
BTMP     RES   1D                                                       0024.000
RET      RES   1W                                                       0025.000
         REL                                                            0026.000
*                                                                       0027.000
* LOAD SOURCE DATA                                                      0028.000
*                                                                       0029.000
C:BSTO  LOAD  2              LOAD ARGUMENTS                             0030.000
CR.BSTO  XCR   R1,R2                                                    0031.000
         CI    R1,8                                                     0032.000
         BLE   CR.BLD                                                   0033.000
         STW   R0,RET         SAVE RETURN ADDRESS                       0034.000
         BL    CR.LBVAL       LOAD ACCUMULATOR VALUE                    0035.000
         LB    R4,DD.D,X1     LOAD DESTINATION SCALE FACTOR             0036.000
         SLL   R4,26             AND EXTEND SIGN                        0037.000
         SRA   R4,26                                                    0038.000
         TRR   R1,R2          RESTORE DESTINATION DD TO R2              0039.000
         SUR   R4,R5          DETERMINE R5-R4                           0040.000
         BZ    SAVEIT         IF DIFFERENCE IS ZERO, GO SAVE ACC        0041.000
*                                                                       0042.000
* SCALE (R6,R7) TO ALIGN DECIMAL POINTS                                 0043.000
*                                                                       0044.000
         BP    RSCALE                                                   0045.000
         BL    CR.LSCL        SCALE (R6,R7) LEFT                        0046.000
         TRR   R5,R5          IF R5 IS NOW ZERO                         0047.000
         BZ    SAVEIT            THEN GO SAVE ACC                       0048.000
*                                                                       0049.000
* FLAG SIZE ERROR                                                       0050.000
*                                                                       0051.000
SIZE     SBM   1,SIZERR       SET SIZE FLAG                             0052.000
         BU    *RET           RETURN                                    0053.000
*                                                                       0054.000
* SCALE (R6,R7) RIGHT                                                   0055.000
*                                                                       0056.000
RSCALE   BL    CR.RSCL                                                  0057.000
*                                                                       0058.000
* TEST FOR SIZE ERROR                                                   0059.000
*                                                                       0060.000
SAVEIT   LW    R0,RET         LOAD RETURN ADDRESS                       0061.000
         TBM   1,ONSZ         IF ON SIZE CONDITION IS NOT SPECIFIED     0062.000
         BNS   CR.SBVAL          THEN GO STORE BINARY VALUE             0063.000
         STD   R6,BTMP                                                  0064.000
         TBM   0,BTMP                                                   0065.000
         BNS   $+2W           IF BTMP < 0                               0066.000
         LND   R6,BTMP           THEN NEGATE (R6,R7)                    0067.000
         LH    R3,DD.LEN,X1   LOAD SIZE OF DESTINATION                  0068.000
         TRR   R3,R5                                                    0069.000
         SLL   R3,3                                                     0070.000
         CAMD  R6,POW10,X3    IF (R6,R7) >= 10**R5                      0071.000
         BGE   SIZE              THEN GO FLAG SIZE ERROR                0072.000
*                                                                       0073.000
* SAVE BTMP IN DESTINATION                                              0074.000
*                                                                       0075.000
         LD    R6,BTMP        GET VALUE OF BTMP                         0076.000
         BU    CR.SBVAL          AND GO SAVE IT                         0077.000
         END                                                            0078.000
