         TITLE 'MCE PRINT PROGRAM - DATE SUBROUTINE'                    MCE00010
MCT401DT CSECT                                                          MCE00020
MCT401DT AMODE ANY                    (11.0)                            MCE00030
MCT401DT RMODE ANY                    (11.0)                            MCE00040
         USING *,R12                                                    MCE00050
         STM   R14,R12,12(R13)                                          MCE00060
         LR    R12,R15                                                  MCE00070
         LA    R2,SVREGS                                                MCE00080
         ST    R2,8(R13)                                                MCE00090
         ST    R13,4(R2)                                                MCE00100
         LR    R13,R2                                                   MCE00110
         B     ONWARD                                                   MCE00120
         DC    C'MCT401DT'                                              MCE00130
*********************************************************************** MCE00140
* GET TODAYS DATE AND CONVERT FROM YYDDD TO MMDDYY                      MCE00150
* AT ENTRY, R9->FIELD TO PUT DATE IN (SCHAR)                            MCE00160
*********************************************************************** MCE00170
ONWARD   XR    R0,R0                                                    MCE00180
         XR    R1,R1                                                    MCE00190
         XC    PWORK,PWORK                                              MCE00200
         SVC   11                     GET DATE                          MCE00210
         ST    R1,PWORK+4                                               MCE00220
         CVB   R2,PWORK                                                 MCE00230
         BCTR  R2,0                                                     MCE00240
         SRDA  R2,32                                                    MCE00250
         D     R2,F1000               (3.0)                             MCE00260
         STH   R2,SAVE                R2=DAYS                           MCE00270
         XR    R2,R2                  (15.0)                            MCE00280
         D     R2,F100                (15.0)                            MCE00290
         STC   R2,SAVE+2              (15.0)R2=YEAR                     MCE00300
         STC   R3,CENTID              (15.0)SAVE CENTURY INDICATOR      MCE00310
         LA    R4,CMB                                                   MCE00320
         TM    SAVE+2,3               IS IT A LEAP YEAR                 MCE00330
         BZ    LH5                    YES                               MCE00340
         LA    R4,CMA                                                   MCE00350
LH5      LH    R5,SAVE                                                  MCE00360
         LA    R6,12                                                    MCE00370
         AHI   R5,1                                                     MCE00380
         AHI   R4,22                                                    MCE00390
JMLOOP   CH    R5,0(R4)                                                 MCE00400
         BH    JMGOT                                                    MCE00410
         SH    R4,H2                  (2)                               MCE00420
         BCT   R6,JMLOOP                                                MCE00430
JMGOT    STC   R6,SAVE                MONTH                             MCE00440
         SH    R5,0(R4)                                                 MCE00450
         STC   R5,SAVE+1              DAY                               MCE00460
         LA    R4,SAVE                                                  MCE00470
         LA    R5,2                   (15.0)DO DAY/MONTH                MCE00480
PLP      XR    R7,R7                                                    MCE00490
         IC    R7,0(R4)                                                 MCE00500
         CVD   R7,PWORK                                                 MCE00510
         OI    PWORK+7,X'0F'          ENSURE POSITIVE SIGN BITS         MCE00520
         UNPK  0(2,R9),PWORK+6(2)     (5.0)STORE IN SCHAR               MCE00530
         AHI   R4,1                                                     MCE00540
         AHI   R9,3                   (24.0)                            MCE00550
         BCT   R5,PLP                                                   MCE00560
         CLI   CENTID,1               (15.0)                            MCE00570
         BNE   DO19                   (15.0)                            MCE00580
         MVC   0(2,R9),=CL2'20'       (15.0)                            MCE00590
         B     FIN                    (15.0)                            MCE00600
DO19     MVC   0(2,R9),=CL2'19'       (15.0)                            MCE00610
FIN      AHI   R9,2                   (24.0)                            MCE00620
         XR    R7,R7                  (15.0)                            MCE00630
         IC    R7,0(R4)               (15.0)                            MCE00640
         CVD   R7,PWORK               (15.0)                            MCE00650
         OI    PWORK+7,15             (15.0)                            MCE00660
         UNPK  0(2,R9),PWORK+6(2)     (15.0)                            MCE00670
EXIT     L     R13,4(R13)                                               MCE00680
         LM    R14,R12,12(R13)                                          MCE00690
         XR    R15,R15                                                  MCE00700
         BR    R14                                                      MCE00710
*********************************************************************** MCE00720
PWORK    DS    D                                                        MCE00730
SVREGS   DS    18F                                                      MCE00740
SAVE     DS    3F                                                       MCE00750
F1000    DC    F'1000'                                                  MCE00760
F100     DC    F'100'                 (15.0)                            MCE00770
H2       DC    H'2'                                                     MCE00780
CMA      DC    12H'0,31,59,90,120,151,181,212,243,273,304,334'          MCE00790
CMB      DC    12H'0,31,60,91,121,152,182,213,244,274,305,335'          MCE00800
CENTID   DS    CL1                    (15.0)                            MCE00810
         LTORG                                                          MCE00820
*********************************************************************** MCE00830
* REGISTER EQUATES                                                      MCE00840
*********************************************************************** MCE00850
R0       EQU   0                                                        MCE00860
R1       EQU   1                                                        MCE00870
R2       EQU   2                                                        MCE00880
R3       EQU   3                                                        MCE00890
R4       EQU   4                                                        MCE00900
R5       EQU   5                                                        MCE00910
R6       EQU   6                                                        MCE00920
R7       EQU   7                                                        MCE00930
R8       EQU   8                                                        MCE00940
R9       EQU   9                                                        MCE00950
R10      EQU   10                                                       MCE00960
R11      EQU   11                                                       MCE00970
R12      EQU   12                                                       MCE00980
R13      EQU   13                                                       MCE00990
R14      EQU   14                                                       MCE01000
R15      EQU   15                                                       MCE01010
         END                                                            MCE01020
