*DECK C$ACCDW 
          IDENT  C$ACCDW
          TITLE  CBACCDW  - ACCEPT FROM DAY-OF-WEEK 
          MACHINE  ANY,I
          COMMENT  ACCEPT FROM DAY-OF-WEEK
          SST 
          B1=1
          SPACE  4
**        CBACCDW - ACCEPT FROM DAY-OF-WEEK 
* 
*         CALLING SEQUENCE- 
*                RJ   C.ACCDW 
* 
*         INPUT-
*                NONE 
* 
*         OUTPUT- 
*                X1 CONTAINS THE DAY OF WEEK (1= MONDAY,..., 7=SUNDAY)
*                IN DISPLAY CODE RIGHT-JUSTIFIED AND DISPLAY CODE ZERO
*                FILLED 
* 
*         DOES- 
*                USES SYSTEM MACRO JDATE TO GET THE JULIAN DATE- YYDDD
*                THEN CALCULATES THE DAY-OF-WEEK USING THE FORMULA
*                DOW= (DDD + YY + YY/4) MOD 7 
*                THE FORMULA IS BASED ON THE FACT THAT IN 1900 JAN 1
*                FELL ON A MONDAY AND THAT 365 MODULUS 7 = 1
*                THE EXPRESSION  YY/4   GIVES THE NUMBER OF LEAP
*                YEARS WHICH HAVE OCCURRED SINCE 1900 
* 
*         USES- 
*                A1,X1,X0,X6,A6,A2,X2 
*                A3,X3,B7 (USED IN CBU08R1) 
*                C.ZERO 
*                C.U08R1
* 
          SPACE  4
          ENTRY  C.ACCDW
 C.ACCDW  DATA   0
          JDATE  DATE        GET DATE FROM SYSTEM 
          SA1    DATE        YYDDD
          MX6    30 
          SA2    =XC.ZERO    WORD OF ZEROS
          BX2    X6*X2       MASK OFF LOWER 5 CHARS 
          BX1    X2+X1       C.U08R1 REQUIRES X1 TO BE ZERO FILLED
          MX0    42 
          RJ     =XC.U08R1   CONVERT DDD TO BINARY
          BX6    X1 
          SA6    SAVDDD      SAVE DDD 
          SA1    DATE        YYDDD
          AX1    18          SHIFT OFF DDD
          MX0    48 
          SA2    =XC.ZERO 
          BX2    X0*X2       MASK OFF LOWER 2 CHARS 
          BX1    X2+X1       C.U08R1 REQUIRES X1 TO BE ZERO FILLED
          RJ     =XC.U08R1   CONVERT YY TO BINARY 
          SX6    X1-70
          SA2    SAVDDD      DDD
          PL     X6,ACCDW0   IF YEAR IS LESS THAN 2000
          SX1    X1+100      ADJUST FOR NEXT CENTURY
 ACCDW0   IX2    X2+X1       DDD + YY 
          SX1    X1-1 
          AX1    2           (YY-1)/4 
          IX2    X2+X1       DDD + YY + (YY-1)/4 = N
          SX1    1S19/7+1    (1/7)* 2**19 
          DX1    X2*X1       (N/7)* 2**19 
          AX1    19          N/7
          BX6    X1 
          LX6    3           8*(N/7)
          IX1    X6-X1       8*(N/7)-(N/7) = 7*(N/7)
          IX1    X2-X1       N-7*(N/7) = N MOD 7 = DAY-OF-WEEK
          NZ     X1,ACCDW1
          SX1    7           SUNDAY IS DAY 7
 ACCDW1   BSS    0
          SA2    =XC.ZERO    WORD OF ZEROS
          IX1    X2+X1       CONVERT DOW TO DISPLAY CODE AND BLANK FILL 
          EQ     C.ACCDW
          SPACE  4
 DATE     DATA   0           YYDDD
 SAVDDD   DATA   0           DDD
          END 
