ASMB,R,L,C
      HED "TODAY" RTE UTIL TO FORM STRING OF TODAY'S DATE AND TIME (DLB)
*     NAM TODAY,7 PRE-REL 3-26-76 (DLB) 
      NAM TODAY,7 09570-16293 REV. A 761013 
* 
*-------------------------------------------------------- 
* 
*     RELOC.       09570-16293
*     SOURCE       09570-18293
* 
*     D. BASKINS         13 OCT 76 REV. A 
* 
*---------------------------------------------------------
      ENT TODAY 
      EXT EXEC
      SPC 1 
A     EQU 0 
B     EQU 1 
      SUP 
      SPC 1 
*   PURPOSE:
*     TO BUILD CALLERS 14 WORD BUFFER INTO A DATE/TIME MESSAGE IN 
*     THE FOLLOWING FORM: 
* 
*    "FRI 26 MAR 1976  18:24:30.09" 
*     ----                  ------
*   WHERE:
*     TODAYS DATE IS FRIDAY, MARCH 26, 1976 AND THE TIME IS 
*     6:24 PM & 30.09 SECONDS.
* 
*   NOTES:
*     THE 1ST 2 WORDS MAY BE STRIPED OFF THE BUFFER AND THE LAST
*     THREE WORDS MAY BE STRIPPED OFF TO LOOK LIKE THIS:
* 
*     "26 MAR 1976  18:24"
* 
*   CALLING  &  EXAMPLE PROGRAM:
* 
*    FTN,L
*          PROGRAM DATE 
*          DIMENSION IB(14),IP(5) 
*          CALL RMPAR(IP) 
*        1 CALL TODAY(IB) 
*          CALL EXEC (2,IP,IB,14) 
*          CALL EXEC (2,IP,IB(3),9) 
*          IB(13) = IB(13) - 14 
*          CALL EXEC (2,IP,IB,13) 
*          END
* 
*   WHERE:  IBUF IS A 14 WORD BUFFER AND IS STORED INTO BY
*           THE TODAY SUBROUTINE. 
      SPC 1 
YEAR  NOP 
TMSEC NOP 
SEC   NOP 
MIN   NOP 
HOUR  NOP 
DAY   NOP 
TODAY NOP           ENTRY POINT 
      LDB TODAY,I 
      ISZ TODAY     GET PARAMETER ADDRESS 
      LDA TODAY 
      STB TODAY     SAVE RETURN ADDRESS 
      LDA A,I       TRACK DOWN DIRECT PARAMETER 
      RAL,CLE,SLA,ERA 
      JMP *-2 
      CLE,ELA       CALCULATE STARTING CHARACTOR
      STA CHRAD     OF THE CALLERS BUFFER 
      JSB EXEC      NOW GET TIME FROM SYSTEM
      DEF *+4 
      DEF D11       CALL EXEC (11,IBUF,IYEAR) 
      DEF TMSEC 
      DEF YEAR
      LDA YEAR      GET THE DAY OF WEEK 
      ADA OM1 
      ARS,ARS       WATCH OUT FOR LEAP YEAR 
      ADA YEAR
      ADA DAY 
      CLB 
      DIV O7
      RBL           CALCULATE BUFFER ADDRESS
      ADB DAYWK     POINT TO BUFFER 
      JSB PUT2A     PUT 4 CHARS FROM B-REG TO CALLERS BUF 
      JSB PUT2A     PUT THE NEXT TWO
      LDB DAY 
      ADB DM60      SUBTRACT 2 MONTHS 
      LDA YEAR      GET YEAR
      AND O3        CHECK IF LEAP YEAR
      SZA           LEAP YEAR?
      SSB           OR BEFORE THE 29 FEB
      ADB OM1       NO, LEAP YEAR OR BEFORE FEB 29
      SSB 
      ADB D366      MAR 1 OR LATER ANY YEAR 
      ADB D31 
      LDA B         MPY BY 5
      MPY O5
      DIV D153      LIKE MAGIC, HUH!
      RAL           MPY BY 2
      ADA DEFMO     GET MONTH ADDRESS 
      STA PUT2A     AND SAVE FOR LATER USE
      LDA B         GET REMAINDER 
      CLB           AND DIVIDE BY 5 
      DIV O5        TO GET DAY OF MONTH 
      INA           MINUS ONE 
      JSB PUT2#     PUT 2 DIGIT NUMBER IN BUFFER
      LDB PUT2A     GET MONTH ADDRES
      JSB PUT2A     AND MOVE 4 CHARS
      JSB PUT2A     AND THE NEXT TWO
      LDA O40       PUT IN SPACE
      JSB PUTCR     IN BETWEEN MONTH & YEAR 
      LDA YEAR
      CLB 
      DIV D100
      STB PUT2A     SAVE FRACTION CENTURY FOR LATER 
      JSB PUT2#     PUT TWO DIGIT 19 IN BUFFER
      LDA PUT2A     RETRIVE THE 76
      JSB PUT2#     AND PUT FRACTION OF CENTURY IN BUFFER 
      ISZ CHRAD     CHEAT BY BUMPING PAST SPACE IN BUFFER 
      LDA O40       PUT SPACE IN BUFFER 
      JSB PUTCR     FOR TWO SPACES
      LDA HOUR
      JSB PUT2#     SET IN HOUR 
      LDA COLON 
      JSB PUTCR     PUT IN COLON
      LDA MIN 
      JSB PUT2#     SET IN MINUTES
      LDA COLON     PUT IN COLON
      JSB PUTCR 
      LDA SEC 
      JSB PUT2#     SET IN SECONDS
      LDA PEROD     GET DECEMAL POINT 
      JSB PUTCR 
      LDA TMSEC 
      JSB PUT2#     SET IN TENS OF MILLISECONDS 
      JMP TODAY,I   RETURN DONE 
      SPC 1 
CHRAD NOP           HOLDS CURRENT CHARACTOR ADDRESS 
PUTC1 NOP 
PUTCR NOP           ENTRY A=CHARACTOR TO PUT
      AND O377      MASK OFF HIGH CHARACTOR 
      STB PUTC1     SAVE THE B-REG
      LDB CHRAD     GET CHARACTOR ADDRESS TO PUT
      CLE,ERB       CONVERT TO WORD ADDRESS 
      ISZ CHRAD 
      SEZ,RSS 
      ALF,SLA,ALF   POSITION IF NECESSARY 
      XOR B,I       MERGE IN OLD
      XOR O40       PUT IN/TAKE OUT SPACE 
      STA B,I       AND PUT IN BUFFER 
      LDB PUTC1     RESTORE B-REG 
      JMP PUTCR,I   RETURN DONE 
      SPC 1 
PUT2A NOP           MOVE 4 CHARACTORS FROM ADDRESS
      LDA B,I       GET 1ST CHAR
      ALF,ALF       POSITION
      JSB PUTCR     AND PUT 
      LDA B,I       GET 2ND CHAR
      JSB PUTCR 
      INB           BUMP TO NEXT WORD 
      JMP PUT2A,I   RETURN
      SPC 1 
PUT2# NOP           CONVERT AND PUT 2 DIGIT # IN A-REG
      CLB           FIRST CONVERT 
      DIV D10       NUMBER TO BASE TEN
      ADB O60       CONVERT TO ASCII
      ADA O60       CONVERT TO ASCII
      JSB PUTCR     PUT HIGH DIGIT
      LDA B 
      JSB PUTCR     PUT LOW DIGIT 
      JMP PUT2#,I   RETURN
      SPC 1 
OM1   OCT -1
DM60  DEC -60 
O3    OCT 3 
O5    OCT 5 
O7    OCT 7 
D10   DEC 10
D11   DEC 11
D31   DEC 31
O40   OCT 40
PEROD OCT 56
COLON OCT 72
O60   OCT 60
D100  DEC 100 
D153  DEC 153 
O377  OCT 377 
D366  DEC 366 
DAYWK DEF *+1 
      ASC 14,FRI SAT SUN MON TUE WED THU
DEFMO DEF *-1 
      ASC 12, MAR APR MAY JUN JUL AUG 
      ASC 12, SEP OCT NOV DEC JAN FEB 
      ORR 
      END 
                                                                                                                                                                                                                                      