CHARACTER*10 FUNCTION WEEKDAY (DATE) ! SUBROUTINE WEEKDAY CHARACTER*(*) DATE C*************************************************************************** C*** C*** THIS FUNCTION RETURNS THE DAY OF THE WEEK GIVEN THE STANDARD VMS C*** FORMAT OF A DATE. C*** C*** PARAMETER : C*** C*** DATE_C (C*?) DATE STRING IN STANDARD VMS DATE FORMAT C*** IE: DD-MMM-YY C*** C*** Modification History C*** C*** Programmer Date Description C*** -------------------------------------------------------------------- C*** Jeff Cameron 22-DEC-1994 Adapted for Alpha/AXP C*** -------------------------------------------------------------------- C*** C*************************************************************************** C*MCT C C*** LOCAL DECLARATIONS INTEGER*4 DATE_QUAD(2) INTEGER*4 DAY, STATUS CHARACTER DAY_C*(1) CHARACTER*(9) NAMES(7) / 'Sunday', 'Monday', 'Tuesday', 1 'Wednesday', 'Thursday', 'Friday', 1 'Saturday' / CHARACTER*19 DATE_C C INTEGER*4 LD,I,K,L C INTEGER*4 SYS$BINTIM, SYS$ASCTIM, LIB$DAY INTEGER*4 LENGTH C C*** CONVERT VALUE TO INTERNAL BINARY TIME FORMAT LD = LENGTH (DATE) I = 1 C DO WHILE ((DATE(I:I) .EQ. ' ') .AND. (I .LE. LD)) I = I + 1 END DO C K = I DO WHILE ((DATE(K:K) .NE. '-') .AND. (K .LE. LD)) K = K + 1 END DO C K = K + 1 DO WHILE ((DATE(K:K) .NE. '-') .AND. (K .LE. LD)) K = K + 1 END DO C L = K + 1 C IF ((LD-L) .EQ. 1) THEN DATE_C = DATE (I:K) // '19' // DATE (L:LD) // ' 0:0:0.0' ELSE DATE_C = DATE (I:LD) // ' 0:0:0.0' ENDIF LD = LENGTH (DATE_C) C STATUS = SYS$BINTIM( DATE_C(1:LD), DATE_QUAD ) IF ( .NOT. STATUS ) CALL SYS_SIGNAL (STATUS) C C*** CONVERT BACK TO ASCII SO THE TIME MAY BE STRIPPED OFF AND BACK TO C BINARY AGAIN. STATUS = SYS$ASCTIM( , DATE_C, DATE_QUAD, ) IF ( .NOT. STATUS ) CALL SYS_SIGNAL (STATUS) LD = LENGTH (DATE_C) STATUS = SYS$BINTIM( DATE_C(1:LD), DATE_QUAD ) IF ( .NOT. STATUS ) CALL SYS_SIGNAL (STATUS) C C*** CALCUATE NUMBER DAYS TIL THE USER SUPPLIED DATE. STATUS = LIB$DAY( DAY, DATE_QUAD ) IF ( .NOT. STATUS ) CALL SYS_SIGNAL (STATUS) C C*** DETERMINE THE DAY OF THE WEEK. DAY = MOD ((DAY+3),7) + 1 WEEKDAY = NAMES(DAY) C RETURN END