var/external/bufr/mesgbc.f

   1       SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    MESGBC
   6 C   PRGMMR: KEYSER           ORG: NP22       DATE: 2003-11-04
   7 C
   8 C ABSTRACT: THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH
   9 C  THE MESSAGE TYPE FROM SECTION 1 AND A MESSAGE COMPRESSION INDICATOR
  10 C  UNPACKED FROM SECTION 3.  IT OBTAINS THE BUFR MESSAGE VIA TWO
  11 C  DIFFERENT METHODS, BASED UPON THE SIGN OF LUNIN.
  12 C     IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE READS AND EXAMINES
  13 C  SECTION 1 OF MESSAGES IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE
  14 C  FIRST MESSAGE THAT ACTUALLY CONTAINS REPORT DATA {I.E., BEYOND THE
  15 C  BUFR TABLE (DICTIONARY) MESSAGES AT THE TOP AND, FOR DUMP FILES,
  16 C  BEYOND THE TWO DUMMY MESSAGES CONTAINING THE CENTER TIME AND THE
  17 C  DUMP TIME}.  IT THEN RETURNS THE MESSAGE TYPE AND COMPRESSION
  18 C  INDICATOR FOR THIS FIRST DATA MESSAGE.  IN THIS CASE, THE BUFR FILE
  19 C  SHOULD NOT BE OPENED VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF
  20 C  PRIOR TO CALLING THIS SUBROUTINE.  HOWEVER, THE BUFR FILE MUST BE
  21 C  CONNECTED TO UNIT ABS(LUNIN).  WHEN USED THIS WAY, THIS SUBROUTINE
  22 C  IS IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE MESGBF EXCEPT MESGBF
  23 C  DOES NOT RETURN ANY INFORMATION ABOUT COMPRESSION AND MESGBF READS
  24 C  UNTIL IT FINDS THE FIRST NON-DICTIONARY MESSAGE REGARDLESS OF
  25 C  WHETHER OR NOT IT CONTAINS ANY REPORTS (I.E., IT WOULD STOP AT THE
  26 C  DUMMY MESSAGE CONTAINING THE CENTER TIME FOR DUMP FILES).
  27 C     THE SECOND METHOD IN WHICH THIS SUBROUTINE CAN BE USED OCCURS
  28 C  WHEN LUNIN IS PASSED IN WITH A VALUE LESS THAN ZERO.  IN THIS CASE,
  29 C  IT SIMPLY RETURNS THE MESSAGE TYPE AND COMPRESSION INDICATOR FOR THE
  30 C  BUFR MESSAGE CURRENTLY STORED IN THE INTERNAL MESSAGE BUFFER (ARRAY
  31 C  MBAY IN COMMON BLOCK /BITBUF/).  IN THIS CASE, THE BUFR FILE
  32 C  CONNECTED TO ABS(LUNIN) MUST HAVE BEEN PREVIOUSLY OPENED FOR INPUT
  33 C  OPERATIONS BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE BUFR
  34 C  MESSAGE MUST HAVE BEEN READ INTO MEMORY BY BUFR ARCHIVE LIBRARY
  35 C  ROUTINE READMG OR EQUIVALENT.
  36 C
  37 C PROGRAM HISTORY LOG:
  38 C 2003-11-04  D. KEYSER  -- ORIGINAL AUTHOR
  39 C 2004-06-29  D. KEYSER  -- ADDED NEW OPTION TO RETURN MESSAGE TYPE AND
  40 C                           COMPRESSION INDICATOR FOR BUFR MESSAGE
  41 C                           CURRENTLY STORED IN MEMORY (TRIGGERED BY
  42 C                           INPUT ARGUMENT LUNIN LESS THAN ZERO)
  43 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  44 C                           20,000 TO 50,000 BYTES
  45 C 2005-11-29  J. ATOR    -- USE IUPBS01, GETLENS AND RDMSGW
  46 C 2009-03-23  J. ATOR    -- USE IUPBS3 AND IDXMSG
  47 C 2012-09-15  J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE
  48 C                           ADD OPENBF AND CLOSBF FOR THE CASE
  49 C                           WHEN LUNIN GT 0
  50 C
  51 C USAGE:    CALL MESGBC (LUNIN, MESGTYP, ICOMP)
  52 C   INPUT ARGUMENT LIST:
  53 C     LUNIN    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  54 C                FOR BUFR FILE
  55 C                  - IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE
  56 C                    READS THROUGH ALL BUFR MESSAGES FROM BEGINNING OF
  57 C                    FILE UNTIL IT FINDS THE FIRST MESSAGE CONTAINING
  58 C                    REPORT DATA
  59 C                  - IF LUNIN IS LESS THAN ZERO, THIS SUBROUTINE
  60 C                    OPERATES ON THE BUFR MESSAGE CURRENTLY STORED IN
  61 C                    MEMORY
  62 C
  63 C   OUTPUT ARGUMENT LIST:
  64 C     MESGTYP  - INTEGER: BUFR MESSAGE TYPE FOR EITHER THE FIRST
  65 C                MESSAGE IN FILE CONTAINING REPORT DATA (IF LUNIN > 0),
  66 C                OR FOR THE MESSAGE CURRENTLY IN MEMORY (IF LUNIN < 0)
  67 C                    -256 = for LUNIN > 0 case only: no messages read
  68 C                           or error reading file
  69 C                     < 0 = for LUNIN > 0 case only: none of the
  70 C                           messages read contain reports; this is the
  71 C                           negative of the message type the last
  72 C                           message read (i.e., -11 indicates the BUFR
  73 C                           file contains only BUFR table messages)
  74 C     ICOMP    - INTEGER: BUFR MESSAGE COMPRESSION SWITCH:
  75 C                      -3 = for LUNIN > 0 case only: BUFR file does not
  76 C                           exist
  77 C                      -2 = for LUNIN > 0 case only: BUFR file does not
  78 C                           contain any report messages
  79 C                      -1 = for LUNIN > 0 case only: cannot determine
  80 C                           if first BUFR message containing report
  81 C                           data is compressed due to error reading
  82 C                           file
  83 C                       0 = BUFR message (either first containing
  84 C                           report data if LUNIN > 0, or that currently
  85 C                           in memory if LUNIN < 0) is NOT compressed
  86 C                       1 = BUFR message (either first containing
  87 C                           report data if LUNIN > 0, or that currently
  88 C                           in memory if LUNIN < 0) IS compressed
  89 C
  90 C   INPUT FILES:
  91 C     UNIT ABS(LUNIN) - BUFR FILE
  92 C
  93 C REMARKS:
  94 C    THIS ROUTINE CALLS:        CLOSBF   IDXMSG   IUPBS01  IUPBS3
  95 C                               OPENBF   RDMSGW   STATUS
  96 C    THIS ROUTINE IS CALLED BY: COPYSB   UFBTAB
  97 C                               Also called by application programs.
  98 C
  99 C ATTRIBUTES:
 100 C   LANGUAGE: FORTRAN 77
 101 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 102 C
 103 C$$$
 104
 105       INCLUDE 'bufrlib.prm'
 106
 107       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
 108      .                MBAY(MXMSGLD4,NFILES)
 109
 110       DIMENSION    MSGS(MXMSGLD4)
 111
 112 C-----------------------------------------------------------------------
 113 C-----------------------------------------------------------------------
 114
 115       LUNIT = ABS(LUNIN)
 116
 117 C  DETERMINE METHOD OF OPERATION BASED ON SIGN OF LUNIN
 118 C   LUNIN > 0 - REWIND AND LOOK FOR FIRST DATA MESSAGE (ITYPE = 0)
 119 C   LUNIN < 0 - LOOK AT MESSAGE CURRENLY IN MEMORY     (ITYPE = 1)
 120 C  ---------------------------------------------------------------
 121
 122       ITYPE = 0
 123       IF(LUNIT.NE.LUNIN) ITYPE = 1
 124
 125       ICOMP   =   -1
 126       MESGTYP = -256
 127
 128       IF(ITYPE.EQ.0) THEN
 129
 130          IREC    =    0
 131
 132 C  CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET
 133 C  ---------------------------------------------------------
 134
 135          CALL OPENBF(LUNIT,'INX',LUNIT)
 136
 137 C  READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND
 138 C  -----------------------------------------------------------------
 139
 140 1        CALL RDMSGW(LUNIT,MSGS,IER)
 141          IF(IER.EQ.-1) GOTO 900
 142          IF(IER.EQ.-2) GOTO 901
 143
 144          IREC = IREC + 1
 145
 146          MESGTYP = IUPBS01(MSGS,'MTYP')
 147
 148          IF((IDXMSG(MSGS).EQ.1).OR.(IUPBS3(MSGS,'NSUB').EQ.0)) GOTO 1
 149
 150       ELSE
 151
 152 C  RETURN MESSAGE TYPE FOR MESSAGE CURRENTLY STORED IN MEMORY
 153 C  ----------------------------------------------------------
 154
 155          CALL STATUS(LUNIT,LUN,IL,IM)
 156
 157          DO I=1,12
 158            MSGS(I) = MBAY(I,LUN)
 159          ENDDO
 160
 161          MESGTYP = IUPBS01(MSGS,'MTYP')
 162
 163       END IF
 164
 165 C  SET THE COMPRESSION SWITCH
 166 C  --------------------------
 167
 168       ICOMP = IUPBS3(MSGS,'ICMP')
 169
 170       GOTO 100
 171
 172 C  CAN ONLY GET TO STATEMENTS 900 OR 901 WHEN ITYPE = 0
 173 C  ----------------------------------------------------
 174
 175 900   IF(IREC.EQ.0) THEN
 176          MESGTYP = -256
 177          ICOMP =     -3
 178       ELSE
 179          IF(MESGTYP.GE.0) MESGTYP = -MESGTYP
 180          ICOMP  = -2
 181       ENDIF
 182       GOTO 100
 183
 184 901   MESGTYP = -256
 185       ICOMP =     -1
 186
 187 C  EXIT
 188 C  ----
 189
 190 100   IF(ITYPE.EQ.0) CALL CLOSBF(LUNIT)
 191       RETURN
 192       END