PRINT GEN                                                              
         TITLE 'ALC$BYTE - CONVERT BL1 TO CL8 FOR COBOL PGMS'                   
*  REMARKS:  THIS PROGRAM WILL CONVERT A 1-BYTE BINARY FIELD INTO               
*            8-BYTE CHAR FLD.   IN ESSENCE, COBOL PROGRAMS DO NOT               
*            HANDLE BITS VERY WELL AS IN NOT AT ALL.  SO THIS PROGRAM           
*            TAKE A BL1 FIELD AND EXPLODE IT INTO A CL8 FIELD THUS              
* INDICATING THE 8-BITES IN CHARACTER 0'S AND 1'S                               
*                                                                               
*  CALLING SEQUENCE (FROM A COBOL PROGRAM):                                     
*       CALL 'ALC$BYTE' USING BINARY-BYTE,                                      
*                             CHAR-BYTES.                                       
*              WHERE:                                                           
*                     BINARY-BYTE= BINARY-BYTE     PIC X.                       
*                     CHAR-BYTES = CHAR-BYTES      PIC X(8).                    
*                                                                               
*  REGISTER USAGE                                                               
*       R2  = ADDR OF BINARY BYTE TO BE CONVERTED                               
*       R3  = ADDR OF CHARACTER RETURN AREA                                     
*       R12 = BASE REGISTER 1                                                   
R0       EQU   0                                                                
R1       EQU   1                                                                
R2       EQU   2                                                                
R3       EQU   3                                                                
R4       EQU   4                                                                
R5       EQU   5                                                                
R6       EQU   6                                                                
R7       EQU   7                                                                
R8       EQU   8                                                                
R9       EQU   9                                                                
R10      EQU   10                                                               
R11      EQU   11                                                               
R12      EQU   12                                                               
R13      EQU   13                                                               
R14      EQU   14                                                               
R15      EQU   15                                                               
R00      EQU   0                                                                
R01      EQU   1                                                                
R02      EQU   2                                                                
R03      EQU   3                                                                
R04      EQU   4                                                                
R05      EQU   5                                                                
R06      EQU   6                                                                
R07      EQU   7                                                                
R08      EQU   8                                                                
R09      EQU   9                                                                
         EJECT                                                                  
ALC$BYTE CSECT                                                                  
         USING *,R12                   R1=BASE REGISTERS                        
         STM   R14,R12,12(R13)         SAVE REGISTERS                           
         LR    R12,R15                 ADDRESSIBILITY                           
         LR    R1,R13                  SAVE SAVE AREA POINTER                   
         LA    R13,SAVEAREA            POINT TO MY SAVEAREA                     
         ST    R13,8(0,R1)             SET FORW CHAIN IN CALLERS SAREA          
         ST    R1,4(0,R13)             SET BACK CHAIN IN MY SAVEAREA            
         L     R1,24(0,R1)             REACQUIRE R1 AS IT CAME HERE             
         LM    R2,R3,0(R1)             POINT TO PARMS                           
         USING BINBYTE,R2                                                       
         USING CHARBYTE,R3                                                      
         B     START                                                            
         DS    0F                                                               
         DC    C'*'                                                             
PGMID    DC    CL8'ALC$BYTE '                                                   
         DC    C'*'                                                             
COMPDATE DC    CL8'&SYSDATE'                                                    
COMPTIME DC    CL8'&SYSTIME'                                                    
SAVEAREA DC    18F'0'                                                           
START    EQU   *                                                                
         MVC   CHARBYTE,=C'00000000'   SET ALL BITS TO OFF                      
* CHECK 1ST BIT                                                                 
         TM    BINBYTE,X'80'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE,C'1'           INDICATE THIS BIT IS ON                  
* CHECK 2ND BIT                                                                 
         TM    BINBYTE,X'40'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+1,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 3RD BIT                                                                 
         TM    BINBYTE,X'20'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+2,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 4TH BIT                                                                 
         TM    BINBYTE,X'10'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+3,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 5TH BIT                                                                 
         TM    BINBYTE,X'08'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+4,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 6TH BIT                                                                 
         TM    BINBYTE,X'04'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+5,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 7TH BIT                                                                 
         TM    BINBYTE,X'02'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+6,C'1'         INDICATE THIS BIT IS ON                  
* CHECK 8TH BIT                                                                 
         TM    BINBYTE,X'01'           IS THIS BIT ON?                          
         BNO   *+4+4                   NO, CONTINUE                             
         MVI   CHARBYTE+7,C'1'         INDICATE THIS BIT IS ON                  
$GOBACK  EQU   *                                                                
         L     R13,4(0,R13)            POINT BACK TO CALLERS SAVEAREA           
         LM    R14,R12,12(R13)         RESTORE REGISTERS                        
         BR    R14                     GOBACK TO MOMMA                          
         LTORG                                                                  
         EJECT                                                                  
         DS    0D                                                               
         DSECT                                                                  
BINBYTE  DS    XL1                                                              
         DSECT                                                                  
CHARBYTE DS    CL8                                                              
         EJECT                                                                  
         END