Original IBM HLASM assembler

Excerpt from the source of a date conversion utility by Jay Moseley (All rights acknowledged).


         TITLE 'Y2KDFMT - FORMAT DATE FOR OUTPUT'                       00010000
*                                                                     * 00020000
*   YY   YY   222   KK   KK DDDDDD  FFFFFFF M     MTTTTTTTT           * 00030000
*   YY   YY  2   2  KK  KK  DD   DD FF      MM   MM   TT              * 00040000
*   YY   YY      2  KK KK   DD   DD FF      MMM MMM   TT              * 00050000
*    YY YY       2  KKKK    DD   DD FFFFF   MMMMMMM   TT              * 00060000
*     YYY     222   KKKK    DD   DD FF      MM M MM   TT              * 00070000
*     YY     2      KK KK   DD   DD FF      MM   MM   TT              * 00080000
*     YY     2      KK  KK  DD   DD FF      MM   MM   TT              * 00090000
*     YY     22222  KK   KK DDDDDD  FF      MM   MM   TT              * 00100000
*                                                                     * 00110000
* ******************************************************************* * 00120000
* ******************************************************************* * 00130000
*    THIS SUBROUTINE FORMATS A GIVEN GREGORIAN DATE (MMDDYYYY) IN     * 00140000
*    A LARGE VARIETY OF FORMATS                                       * 00150000
*                                                                     * 00160000
*    1.  VALID INPUT YEARS FOR THIS ROUTINE ARE THE YEARS 1601        * 00170000
*        THROUGH 3399 A. D. (INCLUSIVE)                               * 00180000
*                                                                     * 00190000
*    2.  VALID INPUT MONTH VALUES FOR THIS ROUTINE ARE 01 THROUGH 12. * 00200000
*                                                                     * 00210000
*    3.  VALID INPUT DAY VALUES FOR THIS ROUTINE ARE 01 THROUGH 31    * 00220000
*        WITH EXCEPTIONS FOR THE MONTHS LISTED:                       * 00230000
*             MONTH          MAXIMUM DAY VALUE                        * 00240000
*              04                    30                               * 00250000
*              06                    30                               * 00260000
*              09                    30                               * 00270000
*              11                    30                               * 00280000
*              02                    28                               * 00290000
*              02 DURING LEAP YEAR   29                               * 00300000
*                                                                     * 00310000
*    4.  THE DATE FORMAT MUST BE MMDDYYYY, WHERE MM = THE 2 DIGIT     * 00320000
*        MONTH VALUE, DD = THE 2 DIGIT DAY VALUE, AND YYYY = THE      * 00330000
*        4 DIGIT YEAR VALUE.                                          * 00340000
*                                                                     * 00350000
*    5.  THE MAJOR FORMAT CODE DETERMINES THE OVERALL OUTPUT FORMAT   * 00360000
*        AND THE MINOR FORMAT CODE DETERMINES SUBTLE VARIATIONS OF    * 00370000
*        THE FORMAT:                                                  * 00380000
*          MAJOR                                  MINOR               * 00390000
*            1 = COMMERCIAL (01051997)              1 = NO INSERT     * 00400000
*            1 = COMMERCIAL (01 05 1997)            2 = SPACE         * 00410000
*            2 = EUROPEAN   (05/01/1997)            3 = SLASH         * 00420000
*            2 = EUROPEAN   (05-01-1997)            4 = HYPHEN        * 00430000
*            3 = F.I.P.S.   (YYYY.MM.DD)            5 = PERIOD        * 00440000
*          ---------------------------------------------------------  * 00450000
*            4 = TEXT 1 (JANUARY 5, 1997)           1 = U.S.          * 00460000
*            4 = TEXT 1 (5 JANUARY 1997)            2 = EUROPEAN      * 00470000
*            5 = TEXT 2 (JAN 5, 1997)               1 = U.S.          * 00480000
*            6 = TEXT 3 (SUNDAY, JANUARY 5, 1997)   1 = U.S.          * 00490000
*            7 = TEXT 4 (SUNDAY, 5 JAN 1997)        2 = EUROPEAN      * 00500000
*            8 = TEXT 5 (SUN, JANUARY 5, 1997)      1 = U.S.          * 00510000
*            9 = TEXT 6 (SUN, 5 JAN 1997)           2 = EUROPEAN      * 00520000
*                                                                     * 00530000
*    6.  SIX FIELDS ARE PASSED AS PARAMETERS TO THE ROUTINE:          * 00540000
*        1)  AN 8 BYTE FIELD CONTAINING THE DATE (IN ZONED-           * 00550000
*            DECIMAL FORMAT) TO BE FORMATTED,                         * 00560000
*        2)  A 1 BYTE ZONED-DECIMAL MAJOR FORMAT CODE (SEE 5 ABOVE),  * 00570000
*        3)  A 1 BYTE ZONED-DECIMAL MINOR FORMAT CODE (SEE 5 ABOVE),  * 00580000
*        4)  A 1 BYTE ZONED-DECIMAL RETURN CODE,                      * 00590000
*        5)  A 2 BYTE FIELD WHICH WILL CONTAIN THE NUMBER OF BYTES    * 00600000
*            PLACED IN THE FOLLOWING FIELD (IN ZONED DECIMAL FORMAT), * 00610000
*        6)  AN OUTPUT FIELD TO RECEIVE THE FORMATTED DATE (NOTE:     * 00620000
*            THE SIZE OF THIS FIELD DEPENDS UPON THE FORMATTING       * 00630000
*            CODES ... IT IS THE CALLER'S RESPONSIBILITY TO PASS A    * 00640000
*            FIELD LONG ENOUGH TO RECEIVE THE REQUESTED FORMAT).      * 00650000
*        THE ROUTINE WILL NOT ALTER THE DATE OR FORMAT CODE FIELDS.   * 00660000
*                                                                     * 00670000
*        SUGGESTED CALLING SYNTAX FOR ALC CALLERS:                    * 00680000
*                                                                     * 00690000
*                      CALL  Y2KDFMT,(DATEIN)                         * 00700000
*                         . . .                                       * 00710000
*             DATEIN   DS    ZL8'01051997'                            * 00720000
*             MAJOR    DS    CL1'1'                                   * 00730000
*             MINOR    DS    CL1'3'                                   * 00740000
*             RC       DS    ZL1'0'                                   * 00750000
*             OUTSIZE  DS    ZL2'00'                                  * 00760000
*             OUTDATE  DS    CL29' '                                  * 00770000
*                                                                     * 00780000
*        SUGGESTED CALLING SYNTAX FOR COBOL CALLERS:                  * 00790000
*                                                                     * 00800000
*             01  DFMT-PARAMETERS.                                    * 00810000
*                 02  DATEIN  PIC 9(8) VALUE 01011997.                * 00820000
*                 02  MAJOR   PIC 9(1) VALUE 1.                         00830000
*                 02  MINOR   PIC 9(1) VALUE 3.                         00840000
*                 02  RC      PIC 9(1) VALUE 0.                       * 00850000
*                 02  OUTSIZE PIC 9(2) VALUE 0.                       * 00860000
*                 02  OUTDATE PIC X(29).                              * 00870000
*             CALL 'Y2KDFMT' USING DFMT-PARAMETERS.                   * 00880000
*                                                                     * 00890000
*    7.  THE POSSIBLE VALUES FOR THE RETURN CODE FIELD ARE:           * 00900000
*                                                                     * 00910000
*        0 INDICATES SUCCESSFUL EXECUTION OF THE ROUTINE.             * 00920000
*                                                                     * 00930000
*        2 INDICATES INVALID DATA WAS FOUND IN THE DATE FIELD.        * 00940000
*        INVALID DATA ARE DETERMINED IF THE FIELD'S LOW ORDER         * 00950000
*        BYTE'S ZONE CONTAINS AN INVALID SIGN, (NOT ONE OF            * 00960000
*        X'C', X'D' OR X'F'), OR IF THE PRECEDING BYTES' ZONES        * 00970000
*        ARE OTHER THAN X'F', OR IF ANY BYTE'S LOW ORDER NIBBLE       * 00980000
*        CONTAINS A VALUE GREATER THAN X'9'.                          * 00990000
*                                                                     * 01000000
*        4 INDICATES THE VALUE OF THE YEAR SPECIFIED WAS NOT IN       * 01010000
*        THE RANGE SPECIFIED IN 1 (ABOVE).                            * 01020000
*                                                                     * 01030000
*        6 INDICATES THE VALUE OF THE MONTH SPECIFIED WAS NOT IN      * 01040000
*        THE RANGE SPECIFIED IN 2 (ABOVE).                            * 01050000
*                                                                     * 01060000
*        8 INDICATES THE VALUE OF THE DAY SPECIFIED WAS NOT IN        * 01070000
*        THE RANGE SPECIFIED IN 3 (ABOVE).                            * 01080000
*                                                                     * 01090000
*        3 INDICATES THE VALUE OF THE MAJOR FORMAT CODE SPECIFIED     * 01100000
*        WAS NOT ONE OF THE ACCEPTABLE VALUES (SEE 5 ABOVE).          * 01110000
*                                                                     * 01120000
*        5 INDICATES THE VALUE OF THE MINOR FORMAT CODE SPECIFIED     * 01130000
*        WAS NOT ONE OF THE ACCEPTABLE VALUES FOR THE MAJOR FORMAT    * 01140000
*        CODE SPECIFIED (SEE 5 ABOVE).                                * 01150000
*                                                                     * 01160000
*    8.  UPON SUCCESSFUL EXECUTION, THE FORMATTED DATE WILL BE        * 01170000
*        PLACED IN THE 6TH PARAMETER FIELD AND THE NUMBER OF BYTES    * 01180000
*        PLACED IN THE FIELD WILL BE PLACED IN THE 5TH FIELD.  IF     * 01190000
*        THE RETURN CODE CONTAINS A NON-ZERO VALUE (UNSUCCESSFUL      * 01200000
*        EXECUTION), THE 6TH FIELD WILL NOT BE MODIFIED BY THE        * 01210000
*        ROUTINE AND THE 5TH FIELD WILL CONTAIN ZERO.                 * 01220000
*                                                                     * 01230000
* ******************************************************************* * 01240000
* ******************************************************************* * 01250000
         EJECT                                                          01260000
Y2KDFMT  CSECT                                                          01270000
*         PRINT NOGEN                                                   01280001
         EYEC  'FORMAT DATE WITH FOR PRINT/DISPLAY'                     01290000
*                                                                       01300000
         SAVE  (14,12)                 SAVE CALLER'S REGISTERS          01310000
*                                                                       01320000
         LR    R12,R15                 LOAD BASE WITH ENTRY ADDRESS     01330000
         USING Y2KDFMT,R12             ESTABLISH ADDRESSABILITY         01340000
*                                                                       01350000
         L     R11,0(,R1)              LOAD A(PARAMETERS)               01360000
         USING $PARMS,R11              ESTABLISH ADDRESSABILITY         01370000
*                                                                       01380000
         GETMAIN R,LV=$DYNLEN          GETMAIN DYNAMIC WORKAREA         01390000
         LR    R10,R1                  SAVE A(MEMORY)                   01400000
*                                                                       01410000
         ST    R13,4(,R10)             STORE A(CALLER'S SAVE AREA)      01420000
         ST    R10,8(,R13)             BACK CHAIN A(MY SAVE AREA)       01430000
         LR    R13,R10                 SET A(MY SAVE AREA)              01440000
         USING $DYNMEM,R13             ESTABLISH ADDRESSABILITY         01450000
*                                                                       01460000
*    INSERT EYECATCHER MARKS AT BEGIN/END OF GETMAIN'D AREA.            01470000
*                                                                       01480000
         MVC   TOPFLAG,=C'Y2KDFMT GETMAIN BEGINS->'                     01490000
         MVC   BOTFLAG,=C'<-Y2KDFMT GETMAIN ENDS'                       01500000
*                                                                       01510000
*    INITIALIZE RETURN CODE AND OUTPUT BYTE COUNT.                      01520000
*                                                                       01530000
         MVI   PRC,C'0'                ASSUME GOOD RETURN               01540000
         MVC   PRC+1(2),PRC            ZERO RETURN SIZE                 01550000
*                                                                       01560000
*    CALL Y2KDOWN TO VERIFY DATE AND RETURN INTEGRAL DAY NUMBER.        01570000
*                                                                       01580000
         MVC   DDATE,PDATE             COPY YEAR TO Y2KDOWN PARM        01590000
         LA    R1,DOWNPARM             ADDRESS OF Y2KDOWN PARMS         01600000
         ST    R1,PLIST                STORE IN DYNAMIC AREA            01610000
         LA    R1,PLIST                ADDRESS TO PASS                  01620000
         L     R15,=V(Y2KDOWN)         ADDRESS OF ROUTINE               01630000
         BALR  R14,R15                 CALL ROUTINE                     01640000
*                                                                       01650000
*    SEE IF DATE WE RECEIVED FROM CALLER PASSED EDITS IN Y2KDOWN.       01660000
*    THIS MEANS WE DON'T HAVE TO REPEAT THE EDIT CODE HERE <G>!         01670000
*                                                                       01680000
         MVC   PRC,DRC                 ADOPT RECEIVED RETURN CODE       01690000
         CLI   DRC,C'0'                WAS EXECUTION SUCCESSFUL?        01700000
         BNE   RETURN                  IF NOT, EXIT TO CALLER           01710000
*                                                                       01720000
*    TEST MAJOR FORMAT CODE FOR INVALID VALUE.                          01730000
*                                                                       01740000
         XR    R1,R1                   CLEAR WORK REGISTER              01750000
         IC    R1,PMAJOR               GET MAJOR FORMAT CODE            01760000
         LA    R2,X'F1'                LOWEST VALID CODE                01770000
         LA    R3,9                    HIGHEST VALID CODE               01780000
MAJLOOP  CR    R1,R2                   IS FORMAT VALID?                 01790000
         BE    MAJOK                   YES, CONTINUE                    01800000
         LA    R2,1(,R2)               INCREMENT TO NEXT VALID CODE     01810000
         BCT   R3,MAJLOOP              AND CONTINUE TESTING             01820000
         MVI   PRC,C'3'                INDICATE INVALID CODE            01830000
         B                             RETURN                           01840000
*                                                                       01850000
*    TEST MINOR FORMAT CODE FOR INVALID VALUE.                          01860000
*                                                                       01870000
MAJOK    IC    R1,PMINOR               GET MINOR FORMAT CODE            01880000
         LA    R2,X'F1'                LOWEST VALID CODE                01890000
         LA    R3,5                    HIGHEST VALID CODE FOR MAJ:1-3   01900000
         CLI   PMAJOR,C'4'             IS MAJOR LESS THAN 4?            01910000
         BL    MINLOOP                 YES, BEGIN TEST                  01920000
         LA    R3,2                    ELSE SET HIGHEST FOR MAJ:4-9     01930000
MINLOOP  CR    R1,R2                   IS FORMAT VALID?                 01940000
         BE    MINOK                   YES, CONTINUE                    01950000
         LA    R2,1(,R2)               INCREMENT TO NEXT VALID CODE     01960000
         BCT   R3,MINLOOP              AND CONTINUE TESTING             01970000
         MVI   PRC,C'5'                INDICATE INVALID CODE            01980000
         B                             RETURN                           01990000
*                                                                       02000000
*    BRANCH TO FORMAT ROUTINE BASED ON MAJOR FORMAT CODE                02010000
*                                                                       02020000
MINOK    XR    R3,R3                   CLEAR WORK REGISTER              02030000
         IC    R3,PMAJOR               GET FORMAT NUMBER                02040000
         N     R3,=F'15'               CLEAR SIGN                       02050000
         BCTR  R3,0                    DECREMENT BY 1 (ZERO BASED)      02060000
         SLL   R3,2                    MULTIPLY BY 4 (LENGTH OF BRANCH) 02070000
         LA    R3,MFMTBR(R3)           LOAD ADDRESS OF BRANCH           02080000
         BR    R3                      GO BRANCH DEPENDING ON FORMAT    02090000
*                                                                       02100000
*    BRANCH TABLE TO SELECT ROUTINE FOR MAJOR FORMAT CODE               02110000
*                                                                       02120000
MFMTBR   B     MFMT1                                                    02130000
         B     MFMT2                                                    02140000
         B     MFMT3                                                    02150000
         B     MFMT4                                                    02160000
         B     MFMT5                                                    02170000
         B     MFMT6                                                    02180000
         B     MFMT7                                                    02190000
         B     MFMT8                                                    02200000
         B     MFMT9                                                    02210000
*                                                                       02220000
*    MAJOR FORMAT CODE 1: COMMERCIAL (MMDDYYYY)                         02230000
*                                                                       02240000
MFMT1    BAL   R9,MFMTSUB              GO GET SEPARATOR CHARACTOR       02250000
         LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         02260000
         MVC   0(2,R2),PDATE           MOVE MM                          02270000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02280000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02290000
         BZ    MFMT1A                  NO, JUMP OVER                    02300000
         STC   R3,0(,R2)               INSERT CHARACTER                 02310000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02320000
MFMT1A   MVC   0(2,R2),PDATE+2         MOVE DD                          02330000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02340000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02350000
         BZ    MFMT1B                  NO, JUMP OVER                    02360000
         STC   R3,0(,R2)               INSERT CHARACTER                 02370000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02380000
MFMT1B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        02390000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              02400000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            02410000
*                                                                       02420000
*    MAJOR FORMAT CODE 2: EUROPEAN (DDMMYYYY)                           02430000
*                                                                       02440000
MFMT2    BAL   R9,MFMTSUB              GO GET SEPARATOR CHARACTOR       02450000
         LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         02460000
         MVC   0(2,R2),PDATE+2         MOVE DD                          02470000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02480000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02490000
         BZ    MFMT2A                  NO, JUMP OVER                    02500000
         STC   R3,0(,R2)               INSERT CHARACTER                 02510000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02520000
MFMT2A   MVC   0(2,R2),PDATE           MOVE MM                          02530000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02540000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02550000
         BZ    MFMT2B                  NO, JUMP OVER                    02560000
         STC   R3,0(,R2)               INSERT CHARACTER                 02570000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02580000
MFMT2B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        02590000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              02600000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            02610000
*                                                                       02620000
*    MAJOR FORMAT CODE 3: F.I.P.S. (YYYYMMDD)                           02630000
*                                                                       02640000
MFMT3    BAL   R9,MFMTSUB              GO GET SEPARATOR CHARACTOR       02650000
         LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         02660000
         MVC   0(4,R2),PDATE+4         MOVE YYYY                        02670000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              02680000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02690000
         BZ    MFMT3A                  NO, JUMP OVER                    02700000
         STC   R3,0(,R2)               INSERT CHARACTER                 02710000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02720000
MFMT3A   MVC   0(2,R2),PDATE           MOVE MM                          02730000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02740000
         LTR   R3,R3                   IS THERE AN INSERTION CHAR?      02750000
         BZ    MFMT3B                  NO, JUMP OVER                    02760000
         STC   R3,0(,R2)               INSERT CHARACTER                 02770000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              02780000
MFMT3B   MVC   0(2,R2),PDATE+2         MOVE DD                          02790000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              02800000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            02810000
*                                                                       02820000
*    THIS SUBROUTINE PLACES THE INSERTION CHARACTER (IF ANY) INTO       02830000
*    REGISTER 3 BASED UPON MINOR CODE 1 THROUGH 5 (USED BY MAJOR        02840000
*    CODE ROUTINES 1 THROUGH 3 ABOVE.                                   02850000
*                                                                       02860000
MFMTSUB  XR    R3,R3                   ASSUME NO SEPARATOR              02870000
         XR    R4,R4                   CLEAR WORK REGISTER              02880000
         IC    R4,PMINOR               GET MINOR FORMAT NUMBER          02890000
         N     R4,=F'15'               CLEAR SIGN                       02900000
         BCTR  R4,0                    DECREMENT BY 1 (ZERO BASED)      02910000
         SLL   R4,2                    MULTIPLY BY 4 (LENGTH OF BRANCH) 02920000
         LA    R4,MFMTSBR(R4)          LOAD ADDRESS OF BRANCH           02930000
         BR    R4                      GO BRANCH DEPENDING ON FORMAT    02940000
*                                                                       02950000
*    BRANCH TABLE TO SELECT INSERTION CHARACTER                         02960000
*                                                                       02970000
MFMTSBR  B     MFMTSC1                 NONE                             02980000
         B     MFMTSC2                 SPACE                            02990000
         B     MFMTSC3                 SLASH                            03000000
         B     MFMTSC4                 HYPHEN                           03010000
         B     MFMTSC5                 PERIOD                           03020000
*                                                                       03030000
MFMTSC1  BR    R9                      RETURN TO MAJOR FORMAT           03040000
MFMTSC2  LA    R3,C' '                 SPACE IS INSERTION CHARACTER     03050000
         BR    R9                      RETURN TO MAJOR FORMAT           03060000
MFMTSC3  LA    R3,C'/'                 SPACE IS INSERTION CHARACTER     03070000
         BR    R9                      RETURN TO MAJOR FORMAT           03080000
MFMTSC4  LA    R3,C'-'                 SPACE IS INSERTION CHARACTER     03090000
         BR    R9                      RETURN TO MAJOR FORMAT           03100000
MFMTSC5  LA    R3,C'.'                 SPACE IS INSERTION CHARACTER     03110000
         BR    R9                      RETURN TO MAJOR FORMAT           03120000
*                                                                       03130000
*    MAJOR FORMAT CODE 4: TEXT 1 (MMMMMMMMM D, YYYY)                    03140000
*                                                                       03150000
MFMT4    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         03160000
         CLI   PMINOR,C'2'             EUROPEAN?                        03170000
         BE    MFMT4A                  YES, USE ALTERNATE ORDER         03180000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  03190000
         BAL   R9,MDAY                 MOVE DAY OF MONTH                03200000
         MVC   0(2,R2),=C', '          INSERT COMMA                     03210000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              03220000
         B     MFMT4B                  CONTINUE                         03230000
MFMT4A   BAL   R9,MDAY                 MOVE DAY OF MONTH                03240000
         MVI   0(R2),C' '              INSERT BLANK                     03250000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              03260000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  03270000
MFMT4B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        03280000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              03290000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            03300000
*                                                                       03310000
*    MAJOR FORMAT CODE 5: TEXT 2 (MMM D, YYYY)                          03320000
*                                                                       03330000
MFMT5    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         03340000
         CLI   PMINOR,C'2'             EUROPEAN?                        03350000
         BE    MFMT5A                  YES, USE ALTERNATE ORDER         03360000
         BAL   R9,MMONTHA              MOVE MONTH ABBREVIATION          03370000
         BAL   R9,MDAY                 MOVE DAY OF MONTH                03380000
         MVC   0(2,R2),=C', '          INSERT COMMA                     03390000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              03400000
         B     MFMT5B                  CONTINUE                         03410000
MFMT5A   BAL   R9,MDAY                 MOVE DAY OF MONTH                03420000
         MVI   0(R2),C' '              INSERT BLANK                     03430000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              03440000
         BAL   R9,MMONTHA              MOVE MONTH ABBREVIATION          03450000
MFMT5B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        03460000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              03470000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            03480000
*                                                                       03490000
*    MAJOR FORMAT CODE 6: TEXT 3 (DAYNAME, MMMMMMMMM D, YYYY)           03500000
*                                                                       03510000
MFMT6    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         03520000
         BAL   R9,MDAYN                MOVE DAY OF WEEK NAME            03530000
         CLI   PMINOR,C'2'             EUROPEAN?                        03540000
         BE    MFMT6A                  YES, USE ALTERNATE ORDER         03550000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  03560000
         BAL   R9,MDAY                 MOVE DAY OF MONTH                03570000
         MVC   0(2,R2),=C', '          INSERT COMMA                     03580000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              03590000
         B     MFMT6B                  CONTINUE                         03600000
MFMT6A   BAL   R9,MDAY                 MOVE DAY OF MONTH                03610000
         MVI   0(R2),C' '              INSERT BLANK                     03620000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              03630000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  03640000
MFMT6B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        03650000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              03660000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            03670000
*                                                                       03680000
*    MAJOR FORMAT CODE 7: TEXT 4 (DAYNAME, MMM D, YYYY)                 03690000
*                                                                       03700000
MFMT7    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         03710000
         BAL   R9,MDAYN                MOVE DAY OF WEEK NAME            03720000
         CLI   PMINOR,C'2'             EUROPEAN?                        03730000
         BE    MFMT7A                  YES, USE ALTERNATE ORDER         03740000
         BAL   R9,MMONTHA              MOVE MONTH ABBREVIATION          03750000
         BAL   R9,MDAY                 MOVE DAY OF MONTH                03760000
         MVC   0(2,R2),=C', '          INSERT COMMA                     03770000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              03780000
         B     MFMT7B                  CONTINUE                         03790000
MFMT7A   BAL   R9,MDAY                 MOVE DAY OF MONTH                03800000
         MVI   0(R2),C' '              INSERT BLANK                     03810000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              03820000
         BAL   R9,MMONTHA              MOVE MONTH ABBREVIATION          03830000
MFMT7B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        03840000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              03850000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            03860000
*                                                                       03870000
*    MAJOR FORMAT CODE 8: TEXT 5 (DAY, MMMMMMMMM D, YYYY)               03880000
*                                                                       03890000
MFMT8    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         03900000
         BAL   R9,MDAYA                MOVE DAY OF WEEK ABBREVIATION    03910000
         CLI   PMINOR,C'2'             EUROPEAN?                        03920000
         BE    MFMT8A                  YES, USE ALTERNATE ORDER         03930000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  03940000
         BAL   R9,MDAY                 MOVE DAY OF MONTH                03950000
         MVC   0(2,R2),=C', '          INSERT COMMA                     03960000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              03970000
         B     MFMT8B                  CONTINUE                         03980000
MFMT8A   BAL   R9,MDAY                 MOVE DAY OF MONTH                03990000
         MVI   0(R2),C' '              INSERT BLANK                     04000000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              04010000
         BAL   R9,MMONTHN              MOVE MONTH NAME                  04020000
MFMT8B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        04030000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              04040000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            04050000
*                                                                       04060000
*    MAJOR FORMAT CODE 9: TEXT 6 (DAY, MMM D, YYYY)                     04070000
*                                                                       04080000
MFMT9    LA    R2,POUTDATE             LOAD OUTPUT AREA ADDRESS         04090000
         BAL   R9,MDAYA                MOVE DAY OF WEEK ABBREVIATION    04100000
         CLI   PMINOR,C'2'             EUROPEAN?                        04110000
         BE    MFMT9A                  YES, USE ALTERNATE ORDER         04120000
         BAL   R9,MMONTHA              MOVE MONTH NAME                  04130000
         BAL   R9,MDAY                 MOVE DAY OF ABBREVIATION         04140000
         MVC   0(2,R2),=C', '          INSERT COMMA                     04150000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              04160000
         B     MFMT9B                  CONTINUE                         04170000
MFMT9A   BAL   R9,MDAY                 MOVE DAY OF MONTH                04180000
         MVI   0(R2),C' '              INSERT BLANK                     04190000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              04200000
         BAL   R9,MMONTHA              MOVE MONTH ABBREVIATION          04210000
MFMT9B   MVC   0(4,R2),PDATE+4         MOVE YYYY                        04220000
         LA    R2,4(,R2)               BUMP OUTPUT ADDRESS              04230000
         B     SETSIZE                 SET OUTPUT FIELD SIZE            04240000
*                                                                       04250000
*    MOVE WEEKDAY NAME TO OUTPUT AREA FOLLOWED BY ', ' (COMMON          04260000
*    ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 6/7 ABOVE)         04270000
*                                                                       04280000
MDAYN    BAL   R8,LDAY                 GET ADDRESS/LENGTH OF DAYNAME    04290000
         BCTR  R7,0                    DECREMENT LENGTH FOR EX          04300000
         EX    R7,VARMOVE              MOVE DAY NAME                    04310000
         LA    R7,1(,R7)               RESTORE FULL NAME LENGTH         04320000
         AR    R2,R7                   BUMP OUTPUT ADDRESS              04330000
         MVC   0(2,R2),=C', '          INSERT COMMA/BLANK AFTER NAME    04340000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              04350000
         BR    R9                      AND RETURN                       04360000
*                                                                       04370000
*    MOVE WEEKDAY ABBR TO OUTPUT AREA FOLLOWED BY ', ' (COMMON          04380000
*    ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 7/8 ABOVE)         04390000
*                                                                       04400000
MDAYA    BAL   R8,LDAY                 GET ADDRESS/LENGTH OF DAYNAME    04410000
         LA    R7,2                    ABBR LENGTH MINUS 1 FOR EX       04420000
         EX    R7,VARMOVE              MOVE DAY NAME                    04430000
         LA    R7,1(,R7)               RESTORE FULL MOVE LENGTH         04440000
         AR    R2,R7                   BUMP OUTPUT ADDRESS              04450000
         MVC   0(2,R2),=C', '          INSERT COMMA/BLANK AFTER NAME    04460000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              04470000
         BR    R9                      AND RETURN                       04480000
*                                                                       04490000
*    MOVE MONTH NAME TO OUTPUT AREA FOLLOWED BY A BLANK (COMMON         04500000
*    ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 4/6/8 ABOVE)       04510000
*                                                                       04520000
MMONTHN  BAL   R8,LMONTH               GET ADDRESS/LENGTH OF MONTH      04530000
         BCTR  R7,0                    DECREMENT LENGTH FOR EX          04540000
         EX    R7,VARMOVE              MOVE MONTH NAME                  04550000
         LA    R7,1(,R7)               RESTORE FULL NAME LENGTH         04560000
         AR    R2,R7                   BUMP OUTPUT ADDRESS              04570000
         MVI   0(R2),C' '              INSERT BLANK AFTER NAME          04580000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              04590000
         BR    R9                      AND RETURN                       04600000
VARMOVE  MVC   0(0,R2),0(R6)           VARIABLE MOVE FOR EXECUTE        04610000
*                                                                       04620000
*    MOVE MONTH ABBR TO OUTPUT AREA FOLLOWED BY A BLANK (COMMON         04630000
*    ROUTINE PERFORMED BY MAJOR FORMAT CODE ROUTINES 5/7/9 ABOVE)       04640000
*                                                                       04650000
MMONTHA  BAL   R8,LMONTH               GET ADDRESS/LENGTH OF MONTH      04660000
         LA    R7,2                    ABBR LENGTH MINUS 1 FOR EX       04670000
         EX    R7,VARMOVE              MOVE MONTH NAME                  04680000
         LA    R7,1(,R7)               RESTORE FULL MOVE LENGTH         04690000
         AR    R2,R7                   BUMP OUTPUT ADDRESS              04700000
         MVI   0(R2),C' '              INSERT BLANK AFTER NAME          04710000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              04720000
         BR    R9                      AND RETURN                       04730000
*                                                                       04740000
*    MOVE DAY OF MONTH TO OUTPUT AREA (COMMON ROUTINE PERFORMED FROM    04750000
*    MAJOR FORMAT CODE ROUTINES 4 THROUGH 9 ABOVE)                      04760000
*                                                                       04770000
MDAY     CLI   PDATE+2,C'0'            IS FIRST DIGIT ZERO?             04780000
         BNE   MDAY2                   NO, MOVE BOTH DIGITS             04790000
MDAY1    MVC   0(1,R2),PDATE+3         MOVE ONLY RIGHT DIGIT            04800000
         LA    R2,1(,R2)               BUMP OUTPUT ADDRESS              04810000
         BR    R9                      AND RETURN                       04820000
MDAY2    MVC   0(2,R2),PDATE+2         MOVE BOTH DIGITS                 04830000
         LA    R2,2(,R2)               BUMP OUTPUT ADDRESS              04840000
         BR    R9                      AND RETURN                       04850000
*                                                                       04860000
*    LOAD ADDRESS OF DAY NAME IN R6, LENGTH IN R7 (COMMON ROUTINE       04870000
*    PERFORMED FROM MDAYN AND MDAYA ABOVE)                              04880000
*                                                                       04890000
LDAY     PACK  DWORK(1),DDOW(1)        PACK DAY INTEGRAL NUMBER         04900000
         ZAP   DWORK(8),DWORK(1)       EXPAND TO DOUBLEWORD             04910000
         CVB   R6,DWORK                CONVERT TO BINARY                04920000
         MH    R6,=H'12'               MULTIPLY BY 12 (LENGTH OF ENTRY) 04930000
         LA    R7,DNAME(R6)            LOAD ADDRESS OF NAME'S SIZE      04940000
         LA    R6,2(,R7)               LOAD ADDRESS OF DAY'S NAME       04950000
         LH    R7,0(,R7)               LOAD SIZE OF DAY'S NAME          04960000
         BR    R8                      AND RETURN                       04970000
*                                                                       04980000
*    LOAD ADDRESS OF MONTH NAME IN R6, LENGTH IN R7 (COMMON ROUTINE     04990000
*    PERFORMED FROM MMONTHN AND MMONTHA ABOVE)                          05000000
*                                                                       05010000
LMONTH   PACK  DWORK(2),PDATE(2)       PACK MONTH INTEGRAL NUMBER       05020000
         ZAP   DWORK(8),DWORK(2)       EXPAND TO DOUBLEWORD             05030000
         CVB   R6,DWORK                CONVERT TO BINARY                05040000
         BCTR  R6,0                    DECREMENT BY 1 (ZERO BASED)      05050000
         MH    R6,=H'12'               MULTIPLY BY 12 (LENGTH OF ENTRY) 05060000
         LA    R7,MNAME(R6)            LOAD ADDRESS OF NAME'S SIZE      05070000
         LA    R6,2(,R7)               LOAD ADDRESS OF MONTH'S NAME     05080000
         LH    R7,0(,R7)               LOAD SIZE OF MONTH'S NAME        05090000
         BR    R8                      AND RETURN                       05100000
*                                                                       05110000
*    RETURN THE SIZE OF THE OUTPUT FIELD IN BYTES (COMMON ROUTINE       05120000
*    BRANCHED TO BY ALL MAJOR FORMAT CODE ROUTINES ABOVE)               05130000
*                                                                       05140000
SETSIZE  LA    R1,POUTDATE             GET ADDRESS OF FIELD START       05150000
         SR    R2,R1                   COMPUTE LENGTH OF FIELD          05160000
         CVD   R2,DWORK                CONVERT TO DECIMAL               05170000
         UNPK  DWORK(3),DWORK+6(2)     UNPACK SIZE                      05180000
         OI    DWORK+2,X'F0'           CLEAR SIGN                       05190000
         MVC   PSIZE,DWORK+1           MOVE TO OUTPUT FIELD             05200000
*                                                                       05210000
*    RESTORE REGISTERS, FREE STORAGE, AND RETURN                        05220000
*                                                                       05230000
RETURN   LR    R1,R13                  LOAD ADDRESS OF GETMAINED AREA   05240000
         L     R13,4(,R13)             RELOAD PREVIOUS SAVE AREA        05250000
         LA    R0,$DYNLEN              LOAD LENGTH OF GETMAINED AREA    05260000
         FREEMAIN R,LV=(0),A=(1)       FREE GETMAINED AREA              05270000
         RETURN (14,12),RC=0           RETURN TO CALLER WITH RC=0       05280000
*                                                                       05290000
         EJECT                                                          05300000
* ******************************************************************* * 05310000
* **************************** CONSTANTS **************************** * 05320000
* ******************************************************************* * 05330000
*                                                                       05340000
*    DAY OF WEEK NAMES, PRECEEDED BY LENGTH ATTRIBUTE                   05350000
*                                                                       05360000
DNAME    DC    H'6',CL10'MONDAY  '                                      05370000
         DC    H'7',CL10'TUESDAY '                                      05380000
         DC    H'9',CL10'WEDNESDAY'                                     05390000
         DC    H'8',CL10'THURSDAY '                                     05400000
         DC    H'6',CL10'FRIDAY  '                                      05410000
         DC    H'8',CL10'SATURDAY '                                     05420000
         DC    H'6',CL10'SUNDAY  '                                      05430000
*                                                                       05440000
*    MONTH NAMES, PRECEEDED BY LENGTH ATTRIBUTE                         05450000
*                                                                       05460000
MNAME    DC    H'7',CL10'JANUARY '                                      05470000
         DC    H'8',CL10'FEBRUARY '                                     05480000
         DC    H'5',CL10'MARCH   '                                      05490000
         DC    H'5',CL10'APRIL   '                                      05500000
         DC    H'3',CL10'MAY     '                                      05510000
         DC    H'4',CL10'JUNE    '                                      05520000
         DC    H'4',CL10'JULY    '                                      05530000
         DC    H'6',CL10'AUGUST  '                                      05540000
         DC    H'9',CL10'SEPTEMBER'                                     05550000
         DC    H'7',CL10'OCTOBER '                                      05560000
         DC    H'8',CL10'NOVEMBER '                                     05570000
         DC    H'8',CL10'DECEMBER '                                     05580000
* ******************************************************************* * 05590000
         LTORG                                                          05600000
         EJECT                                                          05610000
* ******************************************************************* * 05620000
* ***************************** EQUATES ***************************** * 05630000
* ******************************************************************* * 05640000
         YREGS                                                          05650000
* ******************************************************************* * 05660000
         EJECT                                                          05670000
* ******************************************************************* * 05680000
* ***************************** DSECTS ****************************** * 05690000
* ******************************************************************* * 05700000
$DYNMEM  DSECT                         DYNAMICALLY ALLOCATED MEMORY     05710000
SAVEAREA DS    18F                     REGISTER SAVE AREA               05720000
TOPFLAG  DS    CL24                    EYECATCHER                       05730000
PLIST    DS    A                       PARMLIST ADDR FOR SUB CALLS      05740000
DOWNPARM DS    0H                      PARAMETERS FOR Y2KDOWN           05750000
DDATE    DS    CL8                       INPUT DATE                     05760000
DRC      DS    CL1                       RETURN CODE                    05770000
DDOW     DS    CL1                       INTEGRAL DAY OF WEEK           05780000
DWORK    DS    D                       DOUBLEWORD WORK FIELD            05790000
BOTFLAG  DS    CL22                    EYECATCHER                       05800000
*                                                                       05810000
$DYNLEN  EQU   (*-$DYNMEM)             LENGTH OF GETMAIN'D AREA         05820000
*                                                                       05830000
$PARMS   DSECT                         PARAMETERS FROM/TO CALLER        05840000
PDATE    DS    CL8                     DATE TO BE PROCESSED             05850000
PMAJOR   DS    CL1                     MAJOR FORMAT CODE                05860000
PMINOR   DS    CL1                     MINOR FORMAT CODE                05870000
PRC      DS    CL1                     RETURN CODE (0, 2-6, 8)          05880000
PSIZE    DS    CL2                     SIZE OF OUTPUT FIELD             05890000
POUTDATE DS    CL1                     OUTPUT DATE (SIZE WILL VARY!)    05900000
* ******************************************************************* * 05910000
         END                                                            05930000