// DATE 060820
// NOHALT
*
*** RUN MAINT.
*
// LOAD $MAINT,F1
// RUN
// COPY FROM-READER,TO-F1,RETAIN-R,LIBRARY-S,NAME-$C4BD
       MACRO
       $C4BD
.*
.*     5703-XM1 CONVERT DECIMAL TO BINARY ROUTINE
.*
       TEXT
       TITLE 'C4BIN2 - CONVERT DECIMAL TO BINARY ROUTINE'
***********************************************************************
*FUNCTION -                                                           *
*   SERIALLY REUSABLE SUBROUTINE TO CONVERT A 4 BYTE POSITIVE DECIMAL *
*   NUMBER A 2 BYTE BINARY VALUE.                                     *
*   A 5 BYTE POSITIVE DECIMAL NUMBER.                                 *
*   ON ENTRY @XR POINTS TO THE LEFT BYTE OF THE DECIMAL VALUE.        *
*   ON RETURN C4BVAL IS THE RIGHT BYTE OF THE 2 BYTES BINARY VALUE    *
*   WHICH MAY BE MODIFIED BY THE USER IN ANY WAY IN IT'S LOCATION.    *
*   THE 4 BYTES DECIMAL VALUE IS NOT ALTERED.                         *
*   @XR IS NOT ALTERED.                                               *
*   @BR IS SAVED AND RESTORED AT EXIT.                                *
***********************************************************************
       SPACE
*                                                                     *
*                  INITIALIZATION                                     *
*                                                                     *
C4BIN2 EQU   *                         ENTRY POINT
       USING C4BIN2,@BR                BASE VALUE
*
       ST    C4B800+@OP1,@BR           SAVE CALLERS BASE REGISTER
       LA    C4BIN2,@BR                LOAD BASE VALUE
*
       ST    C4B850+@OP1(,@BR),@ARR    SAVE RETURN ADDRESS
*
       ST    C4BSAV(,@BR),@XR          SAVE VALUE OF POINTER
       MVI   $CAERR,@@E122             SET ERROR CODE IN CASE
       MVC   C4BVAL(C4BLVL,@BR),C4BINI(,@BR) INIT VALUE TO ZERO
C4B100 MVI   C4B900,4                  INITLZ CHAR. COUNT
*
***    DETERMINE IF CHAR NUMERIC AND DECR CHAR COUNT
*
C4B200 JC    C4B600,@NOP               SET TO UCB IF IMBEDDED BLANKS
*                                      * ALLOWED
C4B300 CLI   0(,@XR),C4BLOW            THIS CHAR NUMERIC ?
       JL    C4B700                    NO, GOTO RETURN
*
       SLC   C4B900(1,@BR),C4B590+@D1(,@BR) DECR CHAR COUNT
       JL    C4B800                    BR TO ERROR EXIT IF TOO MANY
*
***    MULTIPLY PREVIOUS VALUE BY TEN
*
       ALC   C4BVAL(C4BLVL,@BR),C4BVAL(,@BR) DOUBLE PREVIOUS VALUE
       MVC   C4BWRK(C4BLVL,@BR),C4BVAL(,@BR) SAVE DOUBLE VALUE
       ALC   C4BVAL(C4BLVL,@BR),C4BVAL(,@BR) QUADRUPLE PREVIOUS VALUE
       ALC   C4BVAL(C4BLVL,@BR),C4BVAL(,@BR) OCTUPLE PREVIOUS VALUE
       ALC   C4BVAL(C4BLVL,@BR),C4BWRK(,@BR) ADD IN SAVED DOUBLE
*
***    ADD IN VALUE OF THIS CHAR AND INCR POINTER
*
       MNN   C4BCHR(,@BR),0(,@XR)      FETCH NEMERIC VALUE OF NEW CHAR
       ALC   C4BVAL(C4BLVL,@BR),C4BCHR(,@BR) INCR VALU BY THIS CHAR
*
       LA    @B1(,@XR),@XR             INCR POINTER TO NEXT CHAR
       B     C4B200(,@BR)              GOTO DO IT AGAIN
*                                                                     *
*                  ROUTINE TO SCAN BLANKS                             *
*                                                                     *
C4B590 LA    @B1(,@XR),@XR             INCR POINTER TO NEXT CHAR
C4B600 CLI   0(,@XR),@BLANK            IS THIS CHAR A BLANK ?
       BNE   C4B300(,@BR)              RETURN IF NOT
       B     C4B590(,@BR)              GET NEXT CHAR IF YES
       EJECT
*
***    ENDING ROUTINE
*
C4B700 ST    C4BLEN(,@BR),@XR          PLACE VALUE OF POINTER
       SLC   C4BLEN(2,@BR),C4BSAV(,@BR)  SUBRACT ENTERING VALUE
*
C4B800 LA    *-*,@BR                   RESTORE CALLERS BR
*
C4B850 B     *-*                       RETURN TO CALLING ROUTINE
*                                                                     *
*                  WORK AREA AND CONSTANT                             *
*                                                                     *
C4BWRK DS    CL2                       SAVE AREA FOR DOUBLED VALUE
*
C4BYT1 EQU   *                         FIRST BYTE OF BINARY VALUE
C4BVAL DS    CL2                       SAVE AREA FOR BINARY VALUE
*
C4BINI DC    XL1'00'                   INITIALIZE WA TO ZERO
*
C4BCHR DS    CL1                       SAVE AREA FOR EACH NEW CHAR
       ORG   *-1                       INITIALIZE
       DC    XL1'00'                   * TO ZERO
*
C4BSAV DS    CL2                       SAVE AREA FOR XR
*
C4B900 DS    CL1                       SAVE AREA FOR CHAR COUNTER
*                                                                     *
*                  EQUATES FOR C4BIN2                                 *
*                                                                     *
C4BLEN EQU   C4BWRK                    ON RETURN WILL CONTAIN COUNT
*                                      * @XR INCREMENTED BY
C4BCHC EQU   4                         NUMBER OF CHAR TO CONVERT
*
C4BLOW EQU   C'0'                      LOWEST NUMERIC CHARACTER
*
C4BLVL EQU   C4BVAL-C4BWRK             LENGTH OF BINARY VALUE
*
C4BLNK EQU   C4B200+@Q                 LOCATION OF IMBEDDED BLANK IND
*
C4BSPC EQU   @UCB                      MOVED TO C4BLNK TO ALLOW BLANKS
*
C4BNMC EQU   C4B100+@Q                 LOCATION OF CONVERSION COUNT
*
C4BNOP EQU   @NOP                      CHANGED IF IMBEDDED BLANK OK
C4END  EQU   *                         DEFINE END OF CODE
***                       END OF C4BIN2                             ***
       MEND
// CEND
// END
*
// READER CONSOLE