var/external/bufr/rtrcpt.f

   1       SUBROUTINE RTRCPT(LUNIT,IYR,IMO,IDY,IHR,IMI,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RTRCPT
   6 C   PRGMMR: ATOR            ORG: NP12       DATE: 2009-03-23
   7 C
   8 C ABSTRACT: THIS SUBROUTINE RETURNS THE TANK RECEIPT TIME STORED WITHIN
   9 C   SECTION 1 OF THE BUFR MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO
  10 C   BUFR ARCHIVE LIBRARY SUBROUTINE READMG, READMM OR EQUIVALENT.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR
  14 C
  15 C USAGE:    CALL RTRCPT (LUNIT,IYR,IMO,IDY,IHR,IMI,IRET)
  16 C   INPUT ARGUMENT LIST:
  17 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  18 C
  19 C   OUTPUT ARGUMENT LIST:
  20 C     IYR      - INTEGER: TANK RECEIPT YEAR
  21 C     IMO      - INTEGER: TANK RECEIPT MONTH
  22 C     IDY      - INTEGER: TANK RECEIPT DAY
  23 C     IHR      - INTEGER: TANK RECEIPT HOUR
  24 C     IMI      - INTEGER: TANK RECEIPT MINUTE
  25 C     IRET     - INTEGER: RETURN CODE:
  26 C                       0 = normal return
  27 C                      -1 = no tank receipt time was present within the
  28 C                           BUFR message currently open for input
  29 C
  30 C REMARKS:
  31 C    THIS ROUTINE CALLS:        BORT     IUPB     IUPBS01   STATUS
  32 C    THIS ROUTINE IS CALLED BY: None
  33 C                               Normally called only by application
  34 C                               programs.
  35 C
  36 C ATTRIBUTES:
  37 C   LANGUAGE: FORTRAN 77
  38 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  39 C
  40 C$$$
  41
  42       INCLUDE 'bufrlib.prm'
  43
  44       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  45      .                MBAY(MXMSGLD4,NFILES)
  46
  47 C-----------------------------------------------------------------------
  48 C-----------------------------------------------------------------------
  49
  50       IRET = -1
  51
  52 C     Check the file status.
  53
  54       CALL STATUS(LUNIT,LUN,IL,IM)
  55       IF(IL.EQ.0) GOTO 900
  56       IF(IL.GT.0) GOTO 901
  57       IF(IM.EQ.0) GOTO 902
  58
  59 C     Check whether the message contains a tank receipt time.
  60
  61       IF(IUPBS01(MBAY(1,LUN),'BEN').EQ.4) THEN
  62         IS1BYT = 23
  63       ELSE
  64         IS1BYT = 19
  65       ENDIF
  66       IF( (IS1BYT+5) .GT. IUPBS01(MBAY(1,LUN),'LEN1') ) RETURN
  67
  68 C     Unpack the tank receipt time.
  69
  70 C     Note that IS1BYT is a starting byte number relative to the
  71 C     beginning of Section 1, so we still need to account for
  72 C     Section 0 when specifying the actual byte numbers to unpack
  73 C     within the overall message.
  74
  75       IMGBYT = IS1BYT + IUPBS01(MBAY(1,LUN),'LEN0')
  76
  77       IYR = IUPB(MBAY(1,LUN),IMGBYT,16)
  78       IMO = IUPB(MBAY(1,LUN),IMGBYT+2,8)
  79       IDY = IUPB(MBAY(1,LUN),IMGBYT+3,8)
  80       IHR = IUPB(MBAY(1,LUN),IMGBYT+4,8)
  81       IMI = IUPB(MBAY(1,LUN),IMGBYT+5,8)
  82
  83       IRET = 0
  84
  85 C  EXITS
  86 C  -----
  87
  88       RETURN
  89 900   CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT '//
  90      . 'MUST BE OPEN FOR INPUT')
  91 901   CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR '//
  92      . 'OUTPUT; IT MUST BE OPEN FOR INPUT')
  93 902   CALL BORT('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT '//
  94      . 'BUFR FILE; NONE ARE')
  95       END