w3fs15.f

Go to the documentation of this file.

C> @file
C> @brief Updating office note 85 date/time word.
C> @author Ralph Jones @date 1987-02-09
 
C> Updates or backdates a fullword date/time word (o.n. 84) by a specified
C> number of hours.
C>
C> ### Program History Log:
C> Date | Programmer | Comments
C> -----|------------|---------
C> Unknown | Robert Allard | Initial.
C> 1987-02-19 | Ralph Jones | Clean up code
C> 1987-02-19 | Ralph Jones | Change to microsoft fortran 4.10
C> 1989-05-12 | Ralph Jones | Correct order of bytes in date word for pc
C> 1989-08-04 | Ralph Jones | Clean up code, get rid of assign, correction for memory set to indefinite.
C> 1989-10-25 | Ralph Jones | Change to cray cft77 fortran
C> 1995-11-15 | Ralph Jones | Add save statement
C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i
C>
C> @param[in] IDATE Packed binary date/time as follows:
C> Byte | Variable | Range
C> -----|----------|------
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 passing, IDATE and NDATE may
C> be a character*1 array of four, the left 32 bits of 64 bit integer word.
C> An office note 85 label can be stored in 4 integer words. If integer the
C> 2nd word is used. Output is stored in left 32 bits. for a office note 84
C> label the 7th word is in the 4th cray 64 bit integer, the left 32 bits.
C> @param[in] JTAU Number of hours to update (if positive) or backdate (if negative)
C> @param[out] NDATE New date/time word returned in the same format as 'IDATE'.
C> 'NDATE' and 'IDATE' may be the same variable.
C>
C> @note This routine is valid only for the 20th century.
C>
C> @note The format of the date/time word is the same as the seventh word of
C> the packed data field label (see o.n. 84) and the third word of a binary
C> data set label (see o.n. 85).
C>
C> Exit states: An error found by out of range tests on the given date/time
C> information will be indicated by returning a binary zero word in 'NDATE'.
C>
C> @author Ralph Jones @date 1987-02-09
      SUBROUTINE w3fs15(IDATE,JTAU,NDATE)
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