Building an MQ Queue Depth Alert Program in COBOL

The following COBOL program is an IBM MQ queue monitoring utility that checks the depth of queues and reports queues that are approaching capacity.

The program:

-> Connects to an IBM MQ Queue Manager.

-> Reads a list of queue names from an input file.

-> For each queue:

     Opens the queue for inquiry.

     Retrieves:

        Current Queue Depth  

        Maximum Queue Depth  

-> Calculates 70% of the maximum queue depth.

-> Displays the queue name if the current depth is greater than or equal to 70% of its maximum capacity.

-> Closes the queue.

-> Disconnects from MQ after all queues are processed.

       IDENTIFICATION DIVISION.

       PROGRAM-ID. INQDEPTH.

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.

       FILE-CONTROL.

           SELECT INPUT-FILE        ASSIGN TO INFILE.

       DATA DIVISION.

       FILE SECTION.

       FD  INPUT-FILE.

       01  INPUT-REC                   PIC X(48).

       WORKING-STORAGE SECTION.

       01  WS-EOF                      PIC X(01) VALUE 'N'.

       01  WS-CUR-DEPTH                PIC 9(9).

       01  WS-MAX-DEPTH                PIC 9(9).

       01  WS-CALC                     PIC 9(9).

       01  MQ-QM-NAME                  PIC X(48) VALUE SPACES.

       01  MQ-HCONN                    PIC S9(9) COMP-5 VALUE ZERO.

       01  MQ-RC                       PIC S9(9) BINARY.

       01  MQ-RSN                      PIC S9(9) BINARY.

       01  MQ-HOBJ                     PIC S9(9) BINARY.

       01  WS-OPTIONS                  PIC S9(9) BINARY.

       01  WS-SELECTORCOUNT            PIC S9(9) BINARY VALUE 2.

       01  WS-SELECTORS-TABLE.

           05  WS-SELECTORS            PIC S9(9) BINARY OCCURS 2 TIMES.

       01  WS-INTATTRCOUNT             PIC S9(9) BINARY VALUE 2.

       01  WS-INTATTRS-TABLE.

           05  WS-INTATTRS             PIC S9(09) BINARY OCCURS 2 TIMES.

       01  WS-CHARATTRLENGTH           PIC S9(9) BINARY VALUE ZERO.

       01  WS-CHARATTRS                PIC X(01) VALUE LOW-VALUES.

       01  MQM-OBJECT-DESCRIPTOR.

           COPY CMQODV.

       01  MQM-MESSAGE-DESCRIPTOR.

           COPY CMQMDV.

       01  MQM-PUT-MESSAGE-OPTIONS.

           COPY CMQPMOV.

       01  MQM-GET-MESSAGE-OPTIONS.

           COPY CMQGMOV.

       01  MQM-CONSTANTS.

           COPY CMQV SUPPRESS.

       PROCEDURE DIVISION.

       0000-MAIN.

           PERFORM 1000-INITIALIZATION

           PERFORM 2000-PROCESS

              THRU 2000-PROCESS-EXIT

             UNTIL WS-EOF = 'Y'

           PERFORM 3000-TERMINATION

           GOBACK.

       1000-INITIALIZATION.

           ACCEPT MQ-QM-NAME.

           CALL 'MQCONN' USING

                MQ-QM-NAME

                MQ-HCONN

                MQ-RC

                MQ-RSN

           IF MQ-RC = MQCC-FAILED

              DISPLAY 'MQCONN MQ-RC: ' MQ-RC ' MQ-RSN: ' MQ-RSN

           END-IF.

           OPEN INPUT INPUT-FILE.

       2000-PROCESS.

           READ INPUT-FILE

             AT END MOVE 'Y' TO WS-EOF

           END-READ

           IF WS-EOF = 'Y'

              GO TO 2000-PROCESS-EXIT

           END-IF

           PERFORM 2100-OPEN-FOR-INQ

           IF MQ-RC NOT = MQCC-OK

              GO TO 2000-PROCESS-EXIT

           END-IF

           MOVE MQIA-CURRENT-Q-DEPTH TO WS-SELECTORS(1)

           MOVE MQIA-MAX-Q-DEPTH     TO WS-SELECTORS(2)

           MOVE 2                    TO WS-INTATTRCOUNT

                                        WS-SELECTORCOUNT

           CALL 'MQINQ' USING MQ-HCONN

                              MQ-HOBJ

                              WS-SELECTORCOUNT

                              WS-SELECTORS-TABLE

                              WS-INTATTRCOUNT

                              WS-INTATTRS-TABLE

                              WS-CHARATTRLENGTH

                              WS-CHARATTRS

                              MQ-RC

                              MQ-RSN.

           IF MQ-RC NOT = MQCC-OK

              DISPLAY 'QUEUE: ' INPUT-REC

              DISPLAY 'MQINQ  MQ-RC: ' MQ-RC ' MQ-RSN: ' MQ-RSN

           ELSE

              MOVE WS-INTATTRS (1)     TO WS-CUR-DEPTH

              MOVE WS-INTATTRS (2)     TO WS-MAX-DEPTH

              IF WS-CUR-DEPTH > 0

                 COMPUTE WS-CALC = WS-MAX-DEPTH * 0.7

                 IF WS-CUR-DEPTH >= WS-CALC

                    DISPLAY INPUT-REC ' ' WS-CUR-DEPTH ' ' WS-MAX-DEPTH

                 END-IF

              END-IF

           END-IF

           PERFORM 2200-CLOSE-QUEUE.

       2000-PROCESS-EXIT.

           EXIT.

       2100-OPEN-FOR-INQ.

           MOVE MQOT-Q             TO MQOD-OBJECTTYPE

           MOVE INPUT-REC          TO MQOD-OBJECTNAME

           COMPUTE WS-OPTIONS = MQOO-INQUIRE +

                                 MQOO-FAIL-IF-QUIESCING.

           CALL 'MQOPEN' USING MQ-HCONN

                               MQOD

                               WS-OPTIONS

                               MQ-HOBJ

                               MQ-RC

                               MQ-RSN.

           IF MQ-RC NOT = MQCC-OK

              DISPLAY 'QUEUE: ' INPUT-REC

              DISPLAY 'MQOPEN MQ-RC: ' MQ-RC ' MQ-RSN: ' MQ-RSN

           END-IF.

       2100-OPEN-FOR-INQ-EXIT.

           EXIT.

       2200-CLOSE-QUEUE.

           CALL 'MQCLOSE' USING MQ-HCONN

                                MQ-HOBJ

                                MQCO-NONE

                                MQ-RC

                                MQ-RSN.

           IF MQ-RC NOT = MQCC-OK

              DISPLAY 'QUEUE: ' INPUT-REC

              DISPLAY 'MQCLOSE MQ-RC: ' MQ-RC ' MQ-RSN: ' MQ-RSN

           END-IF.

       2200-CLOSE-QUEUE-EXIT.

           EXIT.

       3000-TERMINATION.

           CALL 'MQDISC' USING

                MQ-HCONN

                MQ-RC

                MQ-RSN.

           IF MQ-RC = MQCC-FAILED

              DISPLAY 'MQDISC MQ-RC: ' MQ-RC ' MQ-RSN: ' MQ-RSN

           END-IF.

           CLOSE INPUT-FILE.

       3000-TERMINATION-EXIT.

           EXIT.

𝗣𝗿𝗲𝘃𝗲𝗻𝘁𝗶𝗻𝗴 𝗗𝗕𝟮 𝗧𝗮𝗯𝗹𝗲 𝗖𝗼𝗻𝘁𝗲𝗻𝘁𝗶𝗼𝗻 𝗕𝗲𝘁𝘄𝗲𝗲𝗻 𝗦𝗘𝗟𝗘𝗖𝗧 𝗚𝗿𝗼𝘂𝗽𝘀 𝗮𝗻𝗱 𝗨𝗽𝗱𝗮𝘁𝗲 𝗝𝗼𝗯𝘀 𝗶𝗻 𝗘𝗦𝗣

We encountered a batch processing scenario where a group of jobs (let's call them the "SELECT Group") performed read-only SELECT operations against a DB2 table. These jobs were allowed to run concurrently with each other, but they could not run at the same time as a specific update job (JOBX) that modified the same table, as doing so could result in table contention and job abend.

Initial Approach: Mutual Exclusion with NOTWITH

ESP provides the NOTWITH statement to define mutually exclusive jobs. One option was to configure every job in the SELECT Group with NOTWITH(JOBX) so they would never run concurrently with JOBX.

 

JOB JOB1

    RUN WORKDAYS

    NOTWITH(JOBX)

ENDJOB

 

JOB JOB2

    RUN WORKDAYS

    NOTWITH(JOBX)

ENDJOB

 

JOB JOB3

    RUN WORKDAYS

    NOTWITH(JOBX)

ENDJOB

 

...

...

JOB JOB99

    RUN WORKDAYS

    NOTWITH(JOBX)

ENDJOB

 

To make the exclusion fully bidirectional, JOBX would also need to specify all SELECT jobs in its NOTWITH list:

 

JOB JOBX

    RUN WORKDAYS

    NOTWITH(JOB1,JOB2,JOB3,...JOB99)

ENDJOB

 

While this approach works, it becomes difficult to maintain as the number of jobs grows.

 

Solution with ESP Renewable Resources

 

The RESOURCE statement allows jobs to reserve and release resources before execution. We defined a virtual renewable resource called MY_TABLE with a maximum count of 99.

 

The SELECT Group jobs each required 1 unit of MY_TABLE before they could run. Once a job completed, the resource unit was automatically returned to the pool.

 

JOB JOB1

    RUN WORKDAYS

    RESOURCE (1,MY_TABLE)

ENDJOB

 

JOB JOB2

    RUN WORKDAYS

    RESOURCE (1,MY_TABLE)

ENDJOB

 

JOB JOB3

    RUN WORKDAYS

    RESOURCE (1,MY_TABLE)

ENDJOB

 

...

...

JOB JOB99

    RUN WORKDAYS

    RESOURCE (1,MY_TABLE)

ENDJOB

 

To ensure exclusive access, JOBX was configured to reserve all 99 units of the resource:

 

JOB JOBX

    RUN WORKDAYS

    RESOURCE (99,MY_TABLE)

ENDJOB

 

When JOBX starts, it consumes the entire MY_TABLE resource pool, preventing any SELECT Group jobs from obtaining the single resource unit they require. Conversely, if one or more SELECT jobs are running and holding resource units, JOBX cannot acquire all 99 units and must wait.

 

This approach effectively creates a synchronization mechanism where:

• Multiple SELECT jobs can run concurrently.
• JOBX runs exclusively.
• No SELECT job can run while JOBX is running.
• No lengthy NOTWITH statements are required. 

Final Solution 

Another elegant way to handle this requirement is by using ESP ENQUEUE, which allows a job to request either shared or exclusive access to a resource without requiring the resource to be predefined. ESP automatically prevents jobs with conflicting enqueue requests from running simultaneously, similar to how z/OS enqueues operate.

In our case, we defined a logical resource named MY_TABLE. All jobs in the SELECT Group requested this resource in SHARED mode, allowing them to run concurrently with one another while accessing the table.

JOB JOB1

    RUN WORKDAYS

    ENQUEUE NAME(MY_TABLE) SHARED

ENDJOB

 

JOB JOB2

    RUN WORKDAYS

    ENQUEUE NAME(MY_TABLE) SHARED

ENDJOB

 

JOB JOB3

    RUN WORKDAYS

    ENQUEUE NAME(MY_TABLE) SHARED

ENDJOB

 

...

...

JOB JOB99

    RUN WORKDAYS

    ENQUEUE NAME(MY_TABLE) SHARED

ENDJOB

 

The Update Job (JOBX) was configured to request EXCLUSIVE ownership of the same resource:

JOB JOBX

    RUN WORKDAYS

    ENQUEUE NAME(MY_TABLE) EXCLUSIVE

ENDJOB

With this configuration:

• Multiple SELECT Group jobs can run simultaneously because they all hold a SHARED enqueue on MY_TABLE.
• JOBX cannot start while any SELECT job is running because it requires EXCLUSIVE access.
• Likewise, no SELECT job can start while JOBX holds the exclusive enqueue.
• The solution is simple, scalable, and requires minimal maintenance as SELECT jobs are added or removed.

𝗦𝗰𝗮𝗻𝗻𝗶𝗻𝗴 𝗮 𝟰𝟬 𝗞𝗕 𝗗𝗮𝘁𝗮 𝗔𝗿𝗲𝗮 𝗳𝗼𝗿 𝗟𝗼𝘄𝗲𝗿𝗰𝗮𝘀𝗲 𝗖𝗵𝗮𝗿𝗮𝗰𝘁𝗲𝗿𝘀: 𝗔 𝟱𝟬-𝗠𝗜𝗣𝗦 𝗢𝗽𝘁𝗶𝗺𝗶𝘇𝗮𝘁𝗶𝗼𝗻 𝗦𝘁𝗼𝗿𝘆

A CICS transaction was executing across approximately 150 CICS regions. As part of the transaction flow, a COBOL program contained the code shown below to check for the presence of lowercase alphabetic characters within a 40 KB data area. This code was consuming about 50 MIPS during peak CPU utilization.

MOVE 'N'   TO WS-LC-FOUND          

PERFORM VARYING WS-SUB1 FROM 1 BY 1

   UNTIL WS-SUB1 > LENGTH OF WS-DATA 

      OR WS-LC-FOUND = 'Y'

      IF WS-DATA (WS-SUB1:1) = 'a' OR 'b' OR 'c' OR 'd' OR

                               'e' OR 'f' OR 'g' OR 'h' OR    

                               'i' OR 'j' OR 'k' OR 'l' OR

                               'm' OR 'n' OR 'o' OR 'p' OR

                               'q' OR 'r' OR 's' OR 't' OR 

                               'u' OR 'v' OR 'w' OR 'x' OR 

                               'y' OR'z'

         MOVE 'Y' TO WS-LC-FOUND

      END-IF

END-PEFORM

Initial Optimization Approach

To address the CPU overhead, I developed an assembler-based alternative that used the TRT instruction to perform the lowercase character check far more efficiently than the original COBOL implementation. While the approach achieved significant performance improvements, the customer declined to implement it because assembler code was considered difficult to maintain and support.

Revised Solution

To address the customer's maintainability concerns, I developed an alternative solution using standard COBOL code, shown below. The COBOL compiler internally generated code that leveraged the assembler TRT (Translate and Test) instruction to scan for lowercase characters efficiently. The customer accepted this approach because it avoided the need to maintain assembler source code while still delivering the desired performance benefits. After implementation in production, the solution reduced CPU consumption by approximately 50 MIPS.

 

In the EBCDIC character set, the hexadecimal values for lowercase alphabetic characters are:

• 'a' through 'i': X'81' through X'89'

• 'j' through 'r': X'91' through X'99'

• 's' through 'z': X'A2' through X'A9'

These three contiguous ranges represent all lowercase letters from a to z.

This solution involved defining a custom data type, VALID-DATA, containing every possible byte value except lowercase alphabetic characters (a through z). A PERFORM loop then scanned the data area in 256-byte chunks, verifying that each segment contained only characters defined in VALID-DATA. This coding approach enabled the COBOL compiler to make use of assembler TRT instruction.

       ENVIRONMENT DIVISION.                                   

       CONFIGURATION SECTION.                                  

       SPECIAL-NAMES.                                          

           CLASS VALID-DATA IS X'00' THRU X'80',               

                               X'8A' THRU X'90',               

                               X'9A' THRU X'A1',               

                               X'AA' THRU X'FF'.               

       WORKING-STORAGE SECTION.                                

       01 WS-DATA        PIC X(40000).                         

       01 WS-SUB1        PIC S9(8) COMP.                       

       01 WS-SUB2        PIC S9(8) COMP.                       

       01 WS-QUO         PIC S9(8) COMP.                       

       01 WS-REM         PIC S9(8) COMP.                       

       01 WS-LC-FOUND    PIC X(01).      

   

       PROCEDURE DIVISION.                                     

            MOVE 'N'   TO WS-LC-FOUND                          

            DIVIDE LENGTH OF WS-DATA BY 256 GIVING WS-QUO      

               REMAINDER WS-REM                                

            MOVE 1     TO WS-SUB2                              

            PERFORM VARYING WS-SUB1 FROM 1 BY 1                

              UNTIL WS-SUB1 > WS-QUO                           

                 OR WS-LC-FOUND = 'Y'                          

                 IF WS-DATA (WS-SUB2:256) IS VALID-DATA        

                    CONTINUE                                   

                 ELSE                                          

                    MOVE 'Y' TO WS-LC-FOUND                    

                 END-IF                                        

                 ADD 256   TO WS-SUB2                          

            END-PERFORM                                        

            IF WS-DATA (WS-SUB2:WS-REM) IS VALID-DATA          

               CONTINUE                                        

            ELSE                                               

               MOVE 'Y' TO WS-LC-FOUND                         

            END-IF                                             

𝗢𝗽𝘁𝗶𝗺𝗶𝘇𝗶𝗻𝗴 𝗮 𝗠𝗶𝗰𝗿𝗼 𝗙𝗼𝗰𝘂𝘀 𝗖𝗢𝗕𝗢𝗟 𝗣𝗿𝗼𝗴𝗿𝗮𝗺: 𝗥𝗲𝗱𝘂𝗰𝗶𝗻𝗴 𝗥𝘂𝗻𝘁𝗶𝗺𝗲 𝗳𝗿𝗼𝗺 𝟲𝟬 𝘁𝗼 𝟭𝟱 𝗠𝗶𝗻𝘂𝘁𝗲𝘀

There was a Micro Focus COBOL program running on a Unix platform that processed millions of records. Every time we modified this program for a business requiremnt and tested it, it ran for about 1 hour, making the development and testing process both time-consuming and frustrating.

To improve the situation, I decided to investigate why the program's execution time was so high.

After analyzing the code, I found that for every input record, the program performed a dynamic read against a VSAM indexed file using a partial key and continued reading until the key changed. Since this operation was executed for every input record, it contributed significantly to the overall processing time.

What caught my attention was that the VSAM file contained only about 10,000 records. Given its relatively small size, I determined that loading the entire file into memory would be far more efficient than repeatedly performing indexed file reads. To minimize memory usage, I stored only the key fields and the specific portion of each record required for processing.

However, there was an additional challenge. The program needed to process all records that matched a partial key. Since binary search works only when the search key uniquely identifies an entry, duplicate partial keys required a different approach. To address this, I designed two working-storage tables:

WS-TABLE1 contained unique partial keys along with the starting and ending positions of their corresponding records in a second table.

WS-TABLE2 contained the full key and the data required for processing.

01 WS-TABLE1.

   05 WS-TBL1-CNT                    PIC S9(08) COMP.

      10 WS-TBL1-ENTRY OCCURS 1 TO 10000 TIMES

     DEPENDING ON WS-TBL1-CNT

ASCENDING KEY WS-PARTIAL-KEY

INDEXED BY TBL1-IX.

         15 WS-PARTIAL-KEY           PIC X(06).

         15 WS-START-POS-IN-TBL2     PIC S9(08) COMP.

         15 WS-END-POS-IN-TBL2       PIC S9(08) COMP.

01 WS-TABLE2.

   05 WS-TBL2-CNT                    PIC S9(08) COMP.

      10 WS-TBL2-ENTRY OCCURS 1 TO 10000 TIMES

     DEPENDING ON WS-TBL2-CNT.

         15 WS-FULL-KEY              PIC X(10). 

         15 WS-DATA-TO-PROCESSED     PIC X(20).

The program logic was modified to use the following processing approach:

1. Load the VSAM file into the two in-memory tables during program initialization.

2. Perform a binary search on WS-TABLE1 using the partial key.

3. Once a match was found, retrieve the start and end positions stored in the matching entry.

4. Use those positions to access and process all corresponding records in WS-TABLE2.

By replacing the repeated VSAM indexed reads with an in-memory binary search solution, the program's execution time was reduced from approximately 60 minutes to just 15 minutes.

This optimization resulted in a 75% reduction in runtime, saving about 45 minutes per execution and significantly improving both development testing cycles.

𝗔 𝗦𝗶𝗺𝗽𝗹𝗲 𝗧𝗲𝗰𝗵𝗻𝗶𝗾𝘂𝗲 𝘁𝗼 𝗘𝗻𝘀𝘂𝗿𝗲 𝗢𝗻𝗹𝘆 𝗢𝗻𝗲 𝗝𝗼𝗯 𝗥𝘂𝗻𝘀 𝗮𝘁 𝗮 𝗧𝗶𝗺𝗲 𝗶𝗻 𝗮 𝗚𝗿𝗼𝘂𝗽 𝗼𝗳 𝗣𝗮𝗿𝗮𝗹𝗹𝗲𝗹 𝗝𝗼𝗯𝘀

While reviewing our batch processing cycle, I noticed that several jobs contained the following DD statement in their final job step:

//ENQUEUE DD DSN=DUMMY.ENQUEUE.DSN,DISP=OLD

Interestingly, the dataset referenced by this DD statement was completely empty and was not accessed or processed by any program within the job. This raised the question: Why was this dataset included in multiple jobs?

After further analysis, I discovered that this was being used as a simple serialization mechanism. Although these jobs could potentially be scheduled to run in parallel, they were intentionally prevented from doing so to avoid database contention issues.

 

How It Works

The key lies in the DISP=OLD parameter. When a job is selected for execution, z/OS allocates all datasets required by a job step before the step begins execution. Because the dataset DUMMY.ENQUEUE.DSN is requested with DISP=OLD, the system reserves it for exclusive use.

As a result:

• The first job that acquires the dataset proceeds normally.
• Any other job that also requests the same dataset with DISP=OLD must wait until the dataset is released.
• Since the DD statement is present in the last step of each job, the dataset remains allocated until that step completes, effectively ensuring that only one job from the group runs at a time.

This creates a simple enqueue mechanism using dataset allocation.

 

Alternative Approaches

 

Mainframe Job schedulers provide built-in facilities for managing job dependencies, resource constraints, and mutual exclusion requirements. These features are usually more flexible and easier to maintain than relying on dataset allocation techniques.

 

However, the application developers chose to implement serialization using DISP=OLD on a dummy dataset. This may have been due to historical reasons, or perhaps a lack of awareness of the scheduler's resource management capabilities.

Why Binary Fields Never Cause an S0C7 Abend, but Zoned Decimal and Packed Decimal Can

In Mainframe, usually numeric calculations are performed using Binary, Zoned-decimal and packed decimals

One interesting fact is that binary fields never cause an S0C7 data exception, whereas zoned decimal and packed decimal fields can. Let's explore why.
 
Binary fields will NEVER cause S0C7 abend
 
This is demonstrated using the below COBOL code.
 
WORKING-STORAGE SECTION.                            
01 JUNK                            PIC X(04).       
01 WS-BINARY        REDEFINES JUNK PIC 9(08) COMP.  
 
PROCEDURE DIVISION.                                 
 
   MOVE 'ABCD'      TO JUNK.                         
   DISPLAY  'WS-BINARY: ' JUNK WS-BINARY            
   ADD 1 TO WS-BINARY                               
   DISPLAY  'WS-BINARY: ' JUNK WS-BINARY            
                                                    
   MOVE '#$%='      TO JUNK.                        
   DISPLAY  'WS-BINARY: ' JUNK WS-BINARY            
   ADD 1 TO WS-BINARY                               
   DISPLAY  'WS-BINARY: ' JUNK WS-BINARY            
 
The above code does NOT produce S0C7. Output of the above code snippet as follows
 
WS-BINARY: 50766788  
WS-BINARY: 50766789  
WS-BINARY: 69589118
WS-BINARY: 69589119  
 
Case 1: Value "ABCD"
 
'ABCD' is indirectly moved to WS-BINARY. The hexadecimal equivalent of 'ABCD' is X’C1C2C3C4’.  If you put this HEX decimal value in calculator, you will get 3,250,766,788. Since picture clause of WS-BINARY is 9(8), the last 8 digit 50,766,788 is displayed in the first DISPLAY statement.
 
When you add 1 to this value(3,250,766,788), it become 3,250,766,789 and second DISPLAY statement displays last 8 digits which is 50,766,789.
 
 
Case 2: Value "#$%="
 
'#$%=' is indirectly moved to WS-BINARY. The hexadecimal equivalent of '#$%='  is X’7B5B6C7E’.  If you put this HEX decimal value in calculator, you will get 2,069,589,118. Since picture clause of  WS-BINARY is 9(8), the last 8 digit 69,589,118 is displayed in the third DISPLAY statement.
 
When you add 1 to this value(2,069,589,118), it become 2,069,589,119 and fourth DISPLAY statement displays last 8 digits which is  69,589,119.
 
 
Understanding Zoned Decimal and Packed Decimal
 
Before discussing how an S0C7 Data Exception occurs with decimal data, it is important to understand how zoned decimal and packed decimal values are stored internally.
 
Typical zoned decimal declarations in COBOL are shown below:
 
01 WS-NUMBER1 PIC 9(5).     -> Unsigned zoned decimal
01 WS-NUMBER1 PIC 9(5)V99.  -> Unsigned zoned decimal
01 WS-NUMBER2 PIC S9(5)V99. -> Signed zoned decimal
 
Internal representation of Zoned Decimal in Memory
 
In a zoned decimal field:

• Each decimal digit occupies one byte.

• Each byte has 2 nibbles, and each nibble has 4 bits.

• The high-order 4 bits (zone portion) of each byte will always have b’1111’ (hex F) except the last byte.

• The low-order 4 bits (decimal portion) contain the actual numeric digit (0–9).

• In the last byte, first 4 bits will store the sign and second 4 bits will store the last numeric digit.

 

Value	Internal Hex Representation
Unsigned 12345	X'F1F2F3F4F5'
+12345	X'F1F2F3F4A5' X'F1F2F3F4C5' X'F1F2F3F4E5'
-12345	X'F1F2F3F4B5' X'F1F2F3F4D5'

 
 
Sign is stored in the zone portion (high-order 4 bits) of the last byte. Valid signs are given below
 

Sign	Zone Nibble
Unsigned	F
Positive	A,C,E
Negative	B,D

 
Positive signs A, E and negative signs “B” are called non-preferred signs.
 
System always uses “C” for positive signs and “D” for negative signs, but still accepts A,B,E signs
 
When fields with signs A/B/E are involved in the calculations, ultimately sign will be converted to either “C” for positive and “D” for negative
 
Demonstrating Zoned Decimal Sign Handling
 
Let us see how different sign behaves for a zoned decimal field using the below code snippet.
 
WORKING-STORAGE SECTION.          
01 WS-9                PIC S9(05).               
01 WS-X REDEFINES WS-9 PIC X(05). 
 
PROCEDURE DIVISION.               
PARA1.                            
     MOVE X'F1F2F3F4F5' TO WS-X   
     PERFORM CHECK-SIGN           
     MOVE X'F1F2F3F4A5' TO WS-X   
     PERFORM CHECK-SIGN           
     MOVE X'F1F2F3F4C5' TO WS-X   
     PERFORM CHECK-SIGN           
     MOVE X'F1F2F3F4E5' TO WS-X   
     PERFORM CHECK-SIGN           
                                  
     MOVE X'F1F2F3F4B5' TO WS-X   
     PERFORM CHECK-SIGN           
     MOVE X'F1F2F3F4D5' TO WS-X   
     PERFORM CHECK-SIGN           
     GOBACK.   
                
CHECK-SIGN.                       
     IF WS-9 > 0                  
        DISPLAY WS-9 ' POSITIVE'  
     ELSE                         
         IF WS-9 = 0                
            DISPLAY WS-9 ' ZEROS'   
         ELSE                       
            DISPLAY WS-9 ' NEGATIVE'
         END-IF                     
      END-IF.                       
      ADD 1              TO WS-9    
      DISPLAY 'WS-X : ' WS-X.       
 
 
 

Output of the program is given below	Hex value for the number displayed
12345 POSITIVE	X'F1F2F3F4F5'
WS-X : 1234F	X'F1F2F3F4C6'
1234v POSITIVE	X'F1F2F3F4A5'
WS-X : 1234F	X'F1F2F3F4C6'
1234E POSITIVE	X'F1F2F3F4C5'
WS-X : 1234F	X'F1F2F3F4C6'
1234V POSITIVE	X'F1F2F3F4E5'
WS-X : 1234F	X'F1F2F3F4C6'
1234§ NEGATIVE	X'F1F2F3F4B5'
WS-X : 1234M	X'F1F2F3F4D4'
1234N NEGATIVE	X'F1F2F3F4D5'
WS-X : 1234M	X'F1F2F3F4D4'

Typical packed decimal declarations in COBOL are shown below:
 
01 WS-NUMBER1 PIC 9(5) COMP-3.     -> Unsigned packed decimal

01 WS-NUMBER1 PIC 9(5)V99 COMP-3.  -> Unsigned packed decimal

01 WS-NUMBER2 PIC S9(5)V99 COMP-3. -> Signed packed decimal

Internal representation of packed Decimal in Memory
 
In a packed decimal field:

• Each byte has two decimal digits except the last byte
• In the last byte, first 4 bits will store the numeric digit and second 4 bits will store the sign.
• If an odd number of digits exists, the unused high-order nibble is padded with zero.

 

Value	Internal Hex Representation
Unsigned 12345	X'12345F'
+12345	X'12345A' X'12345C’ X'12345E’
-12345	X'12345B' X'12345D’
+123456	X’0123456C’

 
Similar to zoned decimal, system always uses “C” for positive signs and “D” for negative signs for packed decimals, but still accepts A,B,E signs
 
Moving Invalid Data into a Zoned Decimal Field
 
Let us know test moving junk values to a zoned decimal.
 
WORKING-STORAGE SECTION.                           
01 JUNK                            PIC X(04).      
01 WS-ZONED-DECIMAL REDEFINES JUNK PIC 9(04).    
 
PROCEDURE DIVISION.                                
                                                   
   MOVE 'ABCD'      TO JUNK.                       
   DISPLAY  'WS-ZONED-DECIMAL: ' WS-ZONED-DECIMAL  
   ADD 1 TO WS-ZONED-DECIMAL                       
   DISPLAY  'WS-ZONED-DECIMAL: ' WS-ZONED-DECIMAL  
                                                   
   MOVE X'1A1B1C1D' TO JUNK.                       
   DISPLAY  'WS-ZONED-DECIMAL: ' WS-ZONED-DECIMAL  
   ADD 1 TO WS-ZONED-DECIMAL                       
   DISPLAY  'WS-ZONED-DECIMAL: ' WS-ZONED-DECIMAL  
   GOBACK.                                         
 
Output of the above code snippet as follows:
 
WS-ZONED-DECIMAL: ABCD 
WS-ZONED-DECIMAL: 1235 
WS-ZONED-DECIMAL: X'1A1B1C1D' 
CEE3207S The system detected a data exception (System Completion Code=0C7).
 
Code Explanation

Mainframe does not have any instruction to perform arithmetic operations on zoned decimals. So, it first converts zoned-decimals to packed-decimal and then performs arithmetic operations on the packed-decimal.
 
The first move indirectly populated ‘ABCD’(hex value X’C1C2C3C4’) to WS-ZONED-DECIMAL.
 
Before adding one to WS-ZONED-DECIMAL, Value X’C1C2C3C4’ need to be converted to packed-decimal.
 
How Zoned Decimal to Packed Decimal Conversion Works
 
During the conversion process:

• The digit portion of each zoned-decimal byte is treated as a numeric digit.
• The zone bits are ignored except in the rightmost byte.
• The zone bits of the last byte become the sign nibble.
• Digits are packed together from left to right.
• If the packed-decimal result contains an unfilled nibble, it is padded with zero on the left. 

No validation occurs during the conversion itself.
 
Example 1: ‘ABCD’ - X'C1C2C3C4'
 
Value X’C1C2C3C4’ becomes X‘01234C’ after zoned-decimal to packed-decimal conversion.
 
Therefore, the second DISPLAY statement shows 1235, because the temporary packed-decimal representation (X'01234C') was successfully incremented by one during the arithmetic operation.
 
Example 2: X'1A1B1C1D'
 
Value X'1A1B1C1D' becomes X‘0ABCD1’ after zoned-decimal to packed-decimal conversion.
 
Since X‘0ABCD1’ does not adhere to packed-decimal representation, when we tried to add one to it, system produced S0C7 abend

When Does a Packed-Decimal (COMP-3) Field Cause an S0C7 Abend?

As discussed earlier, a packed-decimal field must conform to the valid packed-decimal format. If the field contains invalid digits or an invalid sign nibble and an arithmetic operation is attempted on it, the processor detects the invalid data and raises an S0C7 (Data Exception) abend.