IDENTIFICATION DIVISION.
       PROGRAM-ID.    CENTURY2.
       AUTHOR.        T W HALLORAN.
       DATE-WRITTEN.  OCTOBER 1998.
 
      * THIS PROGRAM FINDS WHERE THE CALLING PROGRAM COMPARES THE
      * PAIR OF FIELDS SPECIFIED IN THE USING CLAUSE OF THE CALL
      * STATEMENT.  IF THE FIELDS ARE DATES THAT BEGIN WITH
      * TWO-DIGIT YEARS MORE THAN 50 YEARS APART, AND NEITHER DATE
      * BEGINS WITH 00000 OR 99999, THIS PROGRAM ASSUMES THAT THE
      * DATES ARE IN DIFFERENT CENTURIES AND TEMPORARILY REVERSES
      * THE ASSOCIATED 'GREATER THAN' OR 'LESS THEN' BRANCH
      * INSTRUCTION. 
 
      * THE TYPES OF DATE FIELDS COMPARED MAY BE ANY COMBINATION
      * OF THESE:
 
      * NUMERIC YYMMDD       PIC 9(6)
      * NUMERIC YYMMDD       PIC 9(6) COMP-3
      * NUMERIC YYDDD        PIC 9(5)
      * NUMERIC YYDDD        PIC 9(5) COMP-3
      * NUMERIC YYMMDD       PIC 9(6) COMP
      * ALPHANUMERIC         PIC X(2) THROUGH X(256)
 
      * TO MAKE THIS PROGRAM WORK CORRECTLY, LITERAL DATES AND
      * CONSTANT DATES IN THE CALLING PROGRAM LIKE 000101, 991231,
      * 00001 OR 99365 MUST BE CHANGED TO 000000, 999999, 00000 OR
      * 99999.  THIS PROGRAM IS DESIGNED TO BE CALLED INDIRECTLY
      * THROUGHT AN INTERMEDIATE PROGRAM LIKE CENTURY1, USING CALL
      * STATEMENTS LIKE THESE:
 
      * EXAMPLE 1:
      *    CALL 'CENTURY1' USING 400-CURRENT-DATE
      *                          22L-DATE-EFFECTIVE-3.
      *    IF 400-CURRENT-DATE < 22L-DATE-EFFECTIVE-3
      *        OR 400-CURRENT-DATE = 22L-DATE-EFFECTIVE-3
 
      * EXAMPLE 2:
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          400-CURRENT-DATE.
      *    IF 450-DATE (450-SUB) < 400-CURRENT-DATE
      *        CALL 'CENTURY1' USING 22L-DATE-EFFECTIVE-3
      *                              400-CURRENT-DATE
      *        IF 22L-DATE-EFFECTIVE-3 > 400-CURRENT-DATE
      *            OR 22L-DATE-EFFECTIVE-3 = 400-CURRENT-DATE
 
      * EXAMPLE 3:
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-SAVE-1-DATE.
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-SAVE-2-DATE.
      *    IF 450-DATE (450-SUB) > 200-SAVE-1-DATE
      *        AND 450-DATE (450-SUB) < 200-SAVE-2-DATE
 
      * EXAMPLE 4:
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-SAVE-1-DATE.
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-SAVE-2-DATE.
      *    IF 450-DATE (450-SUB) > 200-SAVE-1-DATE
      *        AND LESS THAN 200-SAVE-2-DATE
 
      * EXAMPLE 5:
      *    CALL 'CENTURY1'.
      *    CALL 'CENTURY1' USING 300-LABEL-U200
      *                          450-DATE (450-SUB)
      *                          200-SAVE-2-DATE.
      *    PERFORM U200-INCREMENT-450-SUBSCRIPT
      *        UNTIL 450-SUB > 450-ENTRIES
      *        OR 450-DATE (450-SUB) > 200-SAVE-1-DATE.
      *    ...........................................
      *U200-INCREMENT-450-SUBSCRIPT.
      *    ADD 1 TO 450-SUB.
      *    CALL 'CENTURY1' USING 300-LABEL-U200
      *                          450-DATE (450-SUB)
      *                          200-SAVE-2-DATE.
      * EXAMPLE 6:
      *    CALL 'CENTURY1'.
      *    CALL 'CENTURY1' USING 300-LABEL-U200
      *                          450-DATE (450-SUB)
      *                          200-SAVE-2-DATE.
      *    PERFORM UNTIL 450-SUB > 450-ENTRIES
      *            OR 450-DATE (450-SUB) > 200-SAVE-1-DATE
      *        ADD 1 TO 450-SUB
      *        CALL 'CENTURY1' USING 300-LABEL-U200
      *                              450-DATE (450-SUB)
      *                              200-SAVE-2-DATE
      *    END-PERFORM.
 
      * EXAMPLE 7:
      *    CALL 'CENTURY1'.
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-DB-LAST-DATE.
      *    IF 450-CHGLTR (450-SUB) > 200-HID-CHGLTR
      *        AND 450-DATE (450-SUB) > 200-DB-LAST-DATE
 
      * EXAMPLE 8:
      *    CALL 'CENTURY1'.
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          200-DB-LAST-DATE.
      *    CALL 'CENTURY1' USING 450-DATE (450-SUB)
      *                          400-CURRENT-DATE.
      *    IF 450-CHGLTR (450-SUB) > 200-HID-CHGLTR
      *        AND 450-DATE (450-SUB) > 200-DB-LAST-DATE
      *            AND 400-CURRENT-DATE
 
      * CALLING CENTURY1 WITHOUT A USING CLAUSE MEANS THE
      * COMPARISON DOESN'T INVOLVE DATES AND/OR THE ASSOCIATED
      * BRANCH INSTRUCTION IS VALID REGARDLESS OF THE CENTURY,
      * FOR EXAMPLE: WHEN TWO DATES THAT BEGIN WITH TWO-DIGIT
      * YEARS MAY BE MORE THAN 50 YEARS APART BUT STILL IN THE 
      * SAME CENTURY.

      * CALLING CENTURY1 USING A LABEL PARAMETER MEANS THE TWO
      * FIELDS SPECIFIED ARE COMPARED IN THE UNTIL CLAUSE OF
      * THE PERFORM STATEMENT THAT FOLLOWS, OR IN THE UNTIL
      * CLAUSE OF THE PERFORM STATEMENT THAT INVOKES THE CODE
      * CURRENTLY BEING EXECUTED.  THE LABEL PARAMETER MAY BE
      * ANY FOUR-BYTE FIELD WITH A UNIQUE VALUE.
 
      * THE CENTURY1 PROGRAM CAN BE WRITTEN LIKE THIS:
 
      * CENTURY1 CSECT
      *          SAVE   (14,12),,*       SAVE THE REGISTERS
      *          BALR   2,0
      *          USING  *,2              USE REGISTER 2 FOR THIS PROGRAM
      *          ST     13,SAVEAREA+4
      *          LA     13,SAVEAREA      LOAD SAVEAREA ADDRESS
      *          C      1,=X'00000000'
      *          BE     NOPARM           CALL HAS NO USING CLAUSE
      *          TM     4(1),X'80'
      *          BNZ    NOLABEL
      *          MVC    DATE1,4(1)       COPY DATE ADDRESSES
      *          MVC    DATE2,8(1)
      *          MVC    LABEL,0(1)       COPY LABEL ADDRESS
      *          B      WHERE
      * NOPARM   EQU   
      *          LA     3,=C'99999'
      *          ST     3,DATE1          STORE DEFAULT ADDRESS TWICE
      *          ST     3,DATE2
      *          LA     3,=C'NULL'
      *          ST     3,LABEL          STORE DEFAULT LABEL VALUE 
      *          B      WHERE
      * NOLABEL  EQU    *
      *          MVC    DATE1,0(1)       COPY DATE ADDRESSES       
      *          MVC    DATE2,4(1)
      *          LA     3,=C'NULL'
      *          ST     3,LABEL          STORE DEFAULT LABEL VALUE
      * WHERE    EQU    *
      *          ST     14,PARM4         INDICATE WHERE CALLED
      *          CLI    0(14),X'50'
      *          BE     READY
      *          MVC    PARM4,12(9)      USE TGT AT REGISTER 9     
      * READY    EQU    *
      *          LA     3,PARM4          STORE ADDITIONAL PARAMETERS
      *          ST     3,PARM3
      *          LA     1,DATE1
      *          CALL   CENTURY2         CALL CENTURY2 PROGRAM
      *          L      13,SAVEAREA+4
      *          RETURN (14,12),RC=0     RESTORE THE REGISTERS
      * DATE1    DS     1F
      * DATE2    DS     1F
      * PARM3    DS     1F               ADDITIONAL PARAMETERS
      * PARM4    DS     1F
      * LABEL    DS     1F
      * SAVEAREA DS     18F              REGISTER SAVEAREA
      *          END
 
       ENVIRONMENT DIVISION.
 
       DATA DIVISION.
 
       WORKING-STORAGE SECTION.
 
       01  300-WORK-FIELDS.
           05  300-OFF                     PIC X       VALUE '0'.
           05  300-ON                      PIC X       VALUE '1'.
           05  FILLER REDEFINES 300-ON.
               10  300-BAD-NUMBER          PIC S9      COMP-3.
           05  300-CODE-VALUE              PIC S9999   COMP.
           05  300-COMPARED-HERE           PIC X.
           05  300-YEARS-BETWEEN           PIC S999    COMP-3.
           05  300-CALL-LOCATION           PIC S9(9)   COMP.
           05  300-BRANCH-LOCATION         PIC S9(9)   COMP.
           05  FILLER                      PIC X(8)    VALUE 'ERROR->'.
           05  300-ERROR-MESSAGE           PIC X(48)   VALUE SPACES.
           05  FILLER                      PIC X(8)    VALUE '<-ERROR'.
 
       01  400-LOCATION-TABLE              VALUE HIGH-VALUES.
           05  400-TABLE-ENTRY             PIC X(16)   OCCURS 200
                   INDEXED BY 400-INDEX 400-OLD-INDEX.
       01  FILLER REDEFINES 400-LOCATION-TABLE.
           05  FILLER                      OCCURS 1.
               10  400-CALL-LOCATION       PIC S9(9)   COMP.
               10  400-BRANCH-OFFSET       PIC S999    COMP.
               10  400-BRANCH-LOCATION     PIC S9(9)   COMP.
               10  400-OPERATION-TYPE      PIC X.
               10  400-REVERSED-TYPE       PIC X.
               10  400-LABEL-PARM          PIC XXXX.
 
       01  500-INSTRUCTION-AREA.
           05  500-CODE-VALUE              PIC S9999   COMP VALUE +0.
           05  500-TYPE-VALUE              PIC S9999   COMP VALUE +0.
               88  500-VALID-FOR-BC        VALUES +32 THRU +47
                       +64 THRU +79 +176 THRU +191 +208 THRU +223.
               88  500-VALID-FOR-BCR       VALUES +32 THRU +47
                       +64 THRU +79 +160 THRU +191 +208 THRU +223.
               88  500-OK-TO-ADD           VALUES +32 THRU +47
                       +160 THRU +191.
       01  FILLER REDEFINES 500-INSTRUCTION-AREA.
           05  FILLER                      PIC X.
           05  500-OPERATION-CODE          PIC X.
           05  FILLER                      PIC X.
           05  500-OPERATION-TYPE          PIC X.
 
       01  600-SOURCE-DATE                 PIC X(6).
       01  FILLER REDEFINES 600-SOURCE-DATE.
           05  600-SOURCE-YYMMDD           PIC 9(6)    COMP-3.
       01  FILLER REDEFINES 600-SOURCE-DATE.
           05  600-SOURCE-YYDDD            PIC 9(5)    COMP-3.
       01  FILLER REDEFINES 600-SOURCE-DATE.
           05  600-BINARY-YYMMDD           PIC 9(6)    COMP.
 
       01  700-DATE-TABLE.
           05  700-TABLE-ENTRY             OCCURS 2
                       INDEXED BY 700-INDEX.
               10  700-TARGET-DATE         PIC X(6).
               10  FILLER REDEFINES 700-TARGET-DATE.
                   15  700-TARGET-YEAR     PIC 99.
                   15  FILLER              PIC XXXX.
               10  FILLER REDEFINES 700-TARGET-DATE.
                   15  700-TARGET-YYMMDD   PIC 9(6).
               10  FILLER REDEFINES 700-TARGET-DATE.
                   15  700-TARGET-YYDDD    PIC 9(5).
                   15  FILLER              PIC X.
 
       LINKAGE SECTION.
 
       01  750-FIRST-DATE                  PIC X(6).
 
       01  800-SECOND-DATE                 PIC X(6).
 
       01  850-CALL-LOCATION               PIC S9(9)   COMP.
 
       01  900-PROGRAM-CODE.
           05  900-TABLE-ENTRY             OCCURS 1.
               10  900-OPERATION-CODE      PIC X.
               10  900-OPERATION-TYPE      PIC X.
           05  FILLER                      PIC X       OCCURS 299
                   INDEXED BY 900-INDEX 900-MAX-INDEX.
 
       01  950-LABEL-PARM                  PIC XXXX.
 
       PROCEDURE DIVISION USING 750-FIRST-DATE
                                800-SECOND-DATE
                                850-CALL-LOCATION
                                900-PROGRAM-CODE
                                950-LABEL-PARM.
 
       A100-COMPARE-DATE-FIELDS.
           MOVE 850-CALL-LOCATION TO 300-CALL-LOCATION.
           MULTIPLY 16 BY 300-CALL-LOCATION.
           DIVIDE 16 INTO 300-CALL-LOCATION.
           MOVE 300-OFF TO 300-COMPARED-HERE.
           SET 400-INDEX TO 1.
           PERFORM B100-SEARCH-LOCATION-TABLE
               UNTIL 400-TABLE-ENTRY (400-INDEX) = HIGH-VALUES.
           IF 300-COMPARED-HERE = 300-OFF
                   AND 950-LABEL-PARM NOT = 'NULL'
               PERFORM C100-CHECK-FOR-COPY.
           IF 300-COMPARED-HERE = 300-OFF
               PERFORM A200-START-LOOKING-HERE.
           IF 750-FIRST-DATE NOT = 800-SECOND-DATE
               PERFORM A300-CHECK-THESE-DATES.
           GOBACK.
 
       A200-START-LOOKING-HERE.
           SET 900-INDEX 900-MAX-INDEX TO 1.
           SET 900-MAX-INDEX UP BY 299.
           PERFORM D100-FIND-WHERE-COMPARED
               UNTIL 300-COMPARED-HERE = 300-ON
               OR 900-OPERATION-CODE (900-INDEX) = LOW-VALUES
               OR 900-INDEX GREATER THAN 900-MAX-INDEX.
 
       A300-CHECK-THESE-DATES.
           PERFORM E100-COMPUTE-YEARS-BETWEEN.
           IF 300-YEARS-BETWEEN LESS THAN -50
                   OR GREATER THAN 50
               PERFORM F100-NOT-SAME-CENTURY.
 
       B100-SEARCH-LOCATION-TABLE.
           IF 400-CALL-LOCATION (400-INDEX) = 300-CALL-LOCATION
               PERFORM B200-RESET-OPERATION-TYPE.
           SET 400-INDEX UP BY 1.
 
       B200-RESET-OPERATION-TYPE.
           MOVE 300-ON TO 300-COMPARED-HERE.
           SET 900-INDEX TO 400-BRANCH-OFFSET (400-INDEX).
           MOVE 400-OPERATION-TYPE (400-INDEX)
               TO 900-OPERATION-TYPE (900-INDEX).
 
       C100-CHECK-FOR-COPY.
           SET 400-OLD-INDEX TO 400-INDEX.
           PERFORM C200-LOOK-FOR-MATCH
               UNTIL 400-OLD-INDEX = 1
               OR 400-LABEL-PARM (400-OLD-INDEX) = 950-LABEL-PARM.
           IF 400-LABEL-PARM (400-OLD-INDEX) = 950-LABEL-PARM
               PERFORM C300-COPY-THIS-ENTRY.
 
       C200-LOOK-FOR-MATCH.
           SET 400-OLD-INDEX DOWN BY 1.
 
       C300-COPY-THIS-ENTRY.
           IF 400-TABLE-ENTRY (400-INDEX + 1) NOT = HIGH-VALUES
               MOVE 'NOT ENOUGH ROOM IN BRANCH LOCATION TABLE'
                   TO 300-ERROR-MESSAGE
               ADD 1 TO 300-BAD-NUMBER.
           MOVE 300-ON TO 300-COMPARED-HERE.
           MOVE 400-TABLE-ENTRY (400-OLD-INDEX)
               TO 400-TABLE-ENTRY (400-INDEX).
           MOVE 300-CALL-LOCATION TO 400-CALL-LOCATION (400-INDEX).
           SUBTRACT 300-CALL-LOCATION -1
                   FROM 400-BRANCH-LOCATION (400-INDEX)
               GIVING 400-BRANCH-OFFSET (400-INDEX).
 
       D100-FIND-WHERE-COMPARED.
           MOVE 900-OPERATION-CODE (900-INDEX) TO 500-OPERATION-CODE.
           MOVE 900-OPERATION-TYPE (900-INDEX) TO 500-OPERATION-TYPE.
      *    IF OPERATION CODE IS 07, OPERATION IS X'07' (BCR)
      *    IF OPERATION CODE IS 71, OPERATION IS X'47' (BC)
           IF 500-CODE-VALUE = 07
                       AND 500-VALID-FOR-BCR
                   OR 500-CODE-VALUE = 71
                       AND 500-VALID-FOR-BC
               PERFORM D200-BRANCH-IS-VALID.
      *    IF OPERATION CODE IS 65, OPERATION IS X'41' (LA)
           IF 500-CODE-VALUE NOT = 65
               MOVE 500-CODE-VALUE TO 300-CODE-VALUE.
           SET 900-INDEX UP BY 2.
           IF 500-CODE-VALUE GREATER THAN 63
      *        INSTRUCTION LENGTH IS 4 OR 6
               SET 900-INDEX UP BY 2.
           IF 500-CODE-VALUE GREATER THAN 191
      *        INSTRUCTION LENGTH IS 6
               SET 900-INDEX UP BY 2.
 
       D200-BRANCH-IS-VALID.
           SET 300-BRANCH-LOCATION TO 900-INDEX.
           ADD 300-CALL-LOCATION -1
               TO 300-BRANCH-LOCATION.
           SET 400-INDEX TO 1.
           PERFORM D300-SEARCH-LOCATION-TABLE
               UNTIL 400-TABLE-ENTRY (400-INDEX) = HIGH-VALUES.
           IF 400-INDEX = 1
                   OR 400-CALL-LOCATION (400-INDEX - 1)
                       GREATER THAN 300-CALL-LOCATION
                   OR 400-BRANCH-LOCATION (400-INDEX - 1)
                       LESS THAN 300-BRANCH-LOCATION
               PERFORM G100-STORE-THIS-ENTRY.
 
       D300-SEARCH-LOCATION-TABLE.
           SET 400-INDEX UP BY 1.
 
       E100-COMPUTE-YEARS-BETWEEN.
           MOVE 750-FIRST-DATE TO 600-SOURCE-DATE.
           SET 700-INDEX TO 1.
           PERFORM E200-GET-TARGET-YEAR.
           MOVE 800-SECOND-DATE TO 600-SOURCE-DATE.
           SET 700-INDEX TO 2.
           PERFORM E200-GET-TARGET-YEAR.
           SUBTRACT 700-TARGET-YEAR (1) FROM 700-TARGET-YEAR (2)
               GIVING 300-YEARS-BETWEEN.
           IF 700-TARGET-YYDDD (1) = '00000' OR '99999'
                   OR 700-TARGET-YYDDD (2) = '00000' OR '99999'
               MOVE 0 TO 300-YEARS-BETWEEN.
 
       E200-GET-TARGET-YEAR.
           MOVE 600-SOURCE-DATE TO 700-TARGET-DATE (700-INDEX).
           IF 600-SOURCE-YYMMDD NUMERIC
               MOVE 600-SOURCE-YYMMDD TO 700-TARGET-YYMMDD (700-INDEX).
           IF 600-SOURCE-YYDDD NUMERIC
               MOVE 600-SOURCE-YYDDD TO 700-TARGET-YYDDD (700-INDEX).
           IF 700-TARGET-YEAR (700-INDEX) NOT NUMERIC
               MOVE 600-BINARY-YYMMDD TO 700-TARGET-YYMMDD (700-INDEX).
 
       F100-NOT-SAME-CENTURY.
           SET 400-INDEX TO 1.
           PERFORM F200-FIND-WHERE-CALLED
               UNTIL 400-TABLE-ENTRY (400-INDEX) = HIGH-VALUES.
 
       F200-FIND-WHERE-CALLED.
           IF 400-CALL-LOCATION (400-INDEX) = 300-CALL-LOCATION
               PERFORM F300-REVERSE-THIS-BRANCH.
           SET 400-INDEX UP BY 1.
 
       F300-REVERSE-THIS-BRANCH.
           SET 900-INDEX TO 400-BRANCH-OFFSET (400-INDEX).
           MOVE 400-REVERSED-TYPE (400-INDEX)
               TO 900-OPERATION-TYPE (900-INDEX).
 
       G100-STORE-THIS-ENTRY.
           IF 400-TABLE-ENTRY (400-INDEX + 1) NOT = HIGH-VALUES
               MOVE 'NOT ENOUGH ROOM IN BRANCH LOCATION TABLE'
                   TO 300-ERROR-MESSAGE
               ADD 1 TO 300-BAD-NUMBER.
           MOVE 300-ON TO 300-COMPARED-HERE.
           MOVE 300-CALL-LOCATION TO 400-CALL-LOCATION (400-INDEX).
           SET 400-BRANCH-OFFSET (400-INDEX) TO 900-INDEX.
           MOVE 300-BRANCH-LOCATION TO 400-BRANCH-LOCATION (400-INDEX).
           MOVE 500-OPERATION-TYPE TO 400-OPERATION-TYPE (400-INDEX).
           IF 500-CODE-VALUE = 07
               PERFORM G200-CHANGE-BCR-INSTRUCTION
           ELSE
               PERFORM G300-CHANGE-BC-INSTRUCTION.
           MOVE 500-OPERATION-TYPE TO 400-REVERSED-TYPE (400-INDEX).
           MOVE 950-LABEL-PARM TO 400-LABEL-PARM (400-INDEX).
 
       G200-CHANGE-BCR-INSTRUCTION.
      *    'NOT GREATER THAN' IS X'20' THRU 'X'2F'
      *    'NOT LESS THAN' IS X'40' THRU 'X'4F'
      *    'LESS THAN' IS X'A0' THRU 'X'BF'
      *    'GREATER THAN' IS X'D0' THRU 'X'DF'
           IF 500-TYPE-VALUE GREATER THAN 80
      *            IF OPERATION CODE IS 249, OPERATION IS X'F9' (CP)
                   AND 300-CODE-VALUE = 249
               IF 500-OK-TO-ADD
                   ADD 48 TO 500-TYPE-VALUE
               ELSE
                   SUBTRACT 48 FROM 500-TYPE-VALUE
           ELSE
               IF 500-OK-TO-ADD
                   ADD 32 TO 500-TYPE-VALUE
               ELSE
                   SUBTRACT 32 FROM 500-TYPE-VALUE.
 
       G300-CHANGE-BC-INSTRUCTION.
      *    'NOT GREATER THAN' IS X'20' THRU 'X'2F'
      *    'NOT LESS THAN' IS X'40' THRU 'X'4F'
      *    'LESS THAN' IS X'B0' THRU 'X'BF'
      *    'GREATER THAN' IS X'D0' THRU 'X'DF'
           IF 500-OK-TO-ADD
               ADD 32 TO 500-TYPE-VALUE
           ELSE
               SUBTRACT 32 FROM 500-TYPE-VALUE.