SUBROUTINE W3FS15(IDATE,JTAU,NDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FS15 UPDATING OFFICE NOTE 85 DATE/TIME WORD C PRGMMR: REJONES ORG: NMC421 DATE: 89-08-23 C C ABSTRACT: UPDATES OR BACKDATES A FULLWORD DATE/TIME WORD (O.N. 84) C BY A SPECIFIED NUMBER OF HOURS. C C PROGRAM HISTORY LOG: C ??-??-?? R.ALLARD C 87-02-19 R.E.JONES CLEAN UP CODE C 87-02-19 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 C 89-05-12 R.E.JONES CORRECT ORDER OF BYTES IN DATE WORD FOR PC C 89-08-04 R.E.JONES CLEAN UP CODE, GET RID OF ASSIGN, CORRECTION C FOR MEMORY SET TO INDEFINITE. C 89-10-25 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN C 95-11-15 R.E.JONES ADD SAVE STATEMENT C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I C C USAGE: CALL W3FS15 (IDATE, JTAU, NDATE) C INPUT ARGUMENT LIST: C IDATE - PACKED BINARY DATE/TIME AS FOLLOWS: C BYTE 1 IS YEAR OF CENTURY 00-99 C BYTE 2 IS MONTH 01-12 C BYTE 3 IS DAY OF MONTH 01-31 C BYTE 4 IS HOUR 00-23 C SUBROUTINE TAKES ADVANTAGE OF FORTRAN ADDRESS C PASSING, IDATE AND NDATE MAY BE C A CHARACTER*1 ARRAY OF FOUR, THE LEFT 32 C BITS OF 64 BIT INTEGER WORD. AN OFFICE NOTE 85 C LABEL CAN BE STORED IN C 4 INTEGER WORDS. C IF INTEGER THE 2ND WORD IS USED. OUTPUT C IS STORED IN LEFT 32 BITS. FOR A OFFICE NOTE 84 C LABEL THE 7TH WORD IS IN THE 4TH CRAY 64 BIT C INTEGER, THE LEFT 32 BITS. C JTAU - INTEGER NUMBER OF HOURS TO UPDATE (IF POSITIVE) C OR BACKDATE (IF NEGATIVE) C C OUTPUT ARGUMENT LIST: C NDATE - NEW DATE/TIME WORD RETURNED IN THE C SAME FORMAT AS 'IDATE'. 'NDATE' AND 'IDATE' MAY C BE THE SAME VARIABLE. C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - NONE C C RESTRICTIONS: THIS ROUTINE IS VALID ONLY FOR THE 20TH CENTURY. C C NOTES: THE FORMAT OF THE DATE/TIME WORD IS THE SAME AS THE C SEVENTH WORD OF THE PACKED DATA FIELD LABEL (SEE O.N. 84) AND C THE THIRD WORD OF A BINARY DATA SET LABEL (SEE O.N. 85). C C EXIT STATES: C AN ERROR FOUND BY OUT OF RANGE TESTS ON THE GIVEN DATE/TIME C INFORMATION WILL BE INDICATED BY RETURNING A BINARY ZERO WORD C IN 'NDATE'. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C INTEGER ITABYR(13) INTEGER LPTB(13) INTEGER NOLPTB(13) C CHARACTER*1 IDATE(4) CHARACTER*1 NDATE(4) C SAVE C DATA LPTB /0000,0744,1440,2184,2904,3648,4368,5112, & 5856,6576,7320,8040,8784/ DATA NOLPTB/0000,0744,1416,2160,2880,3624,4344,5088, & 5832,6552,7296,8016,8760/ DATA ICENTY/1900/ C C ...WHERE ICENTY IS FOR THE 20TH CENTURY ASSUMED FOR THE GIVEN C ... YEAR WITHIN THE CENTURY C IYR = MOVA2I(IDATE(1)) IMONTH = MOVA2I(IDATE(2)) IDAY = MOVA2I(IDATE(3)) IHOUR = MOVA2I(IDATE(4)) C IF (IYR .GT. 99) GO TO 1600 IF (IMONTH .LE. 0) GO TO 1600 IF (IMONTH .GT. 12) GO TO 1600 IF (IDAY .LE. 0) GO TO 1600 IF (IDAY .GT. 31) GO TO 1600 IF (IHOUR .LT. 0) GO TO 1600 IF (IHOUR .GT. 24) GO TO 1600 IF (JTAU .NE. 0) GO TO 100 C NDATE(1) = IDATE(1) NDATE(2) = IDATE(2) NDATE(3) = IDATE(3) NDATE(4) = IDATE(4) RETURN C 100 CONTINUE JAHR = IYR + ICENTY KABUL = 1 GO TO 900 C C ...WHERE 900 IS SUBROUTINE TO INITIALIZE ITABYR C ...AND RETURN THRU KABUL C 200 CONTINUE IHRYR = IHOUR + 24 * (IDAY - 1) + ITABYR(IMONTH) IHRYR2 = IHRYR + JTAU C C ...TO TEST FOR BACKDATED INTO PREVIOUS YEAR... C 300 CONTINUE IF (IHRYR2 .LT. 0) GO TO 700 C DO 400 M = 2,13 IF (IHRYR2 .LT. ITABYR(M)) GO TO 600 400 CONTINUE C C ...IF IT FALLS THRU LOOP TO HERE, IT IS INTO NEXT YEAR... C JAHR = JAHR + 1 IHRYR2 = IHRYR2 - ITABYR(13) KABUL = 2 GO TO 900 C 600 CONTINUE MONAT = M - 1 IHRMO = IHRYR2 - ITABYR(MONAT) NODAYS = IHRMO / 24 ITAG = NODAYS + 1 IUHR = IHRMO - NODAYS * 24 GO TO 1500 C C ...ALL FINISHED. RETURN TO CALLING PROGRAM....................... C ...COMES TO 700 IF NEG TOTAL HRS. BACK UP INTO PREVIOUS YEAR C 700 CONTINUE JAHR = JAHR - 1 KABUL = 3 GO TO 900 C C ...WHICH IS CALL TO INITIALIZE ITABYR AND RETURN THRU KABUL C 800 CONTINUE IHRYR2 = ITABYR(13) + IHRYR2 GO TO 300 C C ...SUBROUTINE INITYR... C ...CALLED BY GO TO 900 AFTER ASSIGNING RETURN NO. TO KABUL... C ...ITABYR HAS MONTHLY ACCUMULATING TOTAL HRS REL TO BEGIN OF YR. C ...DEPENDS ON WHETHER JAHR IS LEAP YEAR OR NOT. C 900 CONTINUE IQUOT = JAHR / 4 IRMNDR = JAHR - 4 * IQUOT IF (IRMNDR .NE. 0) GO TO 1000 C C ...WAS MODULO 4, SO MOST LIKELY A LEAP YEAR, C IQUOT = JAHR / 100 IRMNDR = JAHR - 100 * IQUOT IF (IRMNDR .NE. 0) GO TO 1200 C C ...COMES THIS WAY IF A CENTURY YEAR... C IQUOT = JAHR / 400 IRMNDR = JAHR - 400 * IQUOT IF (IRMNDR .EQ. 0) GO TO 1200 C C ...COMES TO 1000 IF NOT A LEAP YEAR... C 1000 CONTINUE DO 1100 I = 1,13 ITABYR(I) = NOLPTB(I) 1100 CONTINUE GO TO 1400 C C ...COMES TO 1200 IF LEAP YEAR C 1200 CONTINUE DO 1300 I = 1,13 ITABYR(I) = LPTB(I) 1300 CONTINUE C 1400 CONTINUE GO TO (200,300,800) KABUL C 1500 CONTINUE JAHR = MOD(JAHR,100) NDATE(1) = CHAR(JAHR) NDATE(2) = CHAR(MONAT) NDATE(3) = CHAR(ITAG) NDATE(4) = CHAR(IUHR) RETURN C 1600 CONTINUE NDATE(1) = CHAR(0) NDATE(2) = CHAR(0) NDATE(3) = CHAR(0) NDATE(4) = CHAR(0) C C ...WHICH FLAGS AN ERROR CONDITION ... C RETURN END