var/external/bufr/readerme.f

   1       SUBROUTINE READERME(MESG,LUNIT,SUBSET,JDATE,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    READERME
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1995-06-28
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS INFORMATION FROM A BUFR DATA MESSAGE
   9 C   ALREADY IN MEMORY, PASSED IN AS AN INPUT ARGUMENT.  IT IS SIMILAR
  10 C   TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG EXCEPT, INSTEAD OF
  11 C   READING BUFR MESSAGES DIRECTLY FROM A BUFR FILE THAT IS PHYSICALLY
  12 C   STORED ON THE LOCAL SYSTEM AND INTERFACED TO THE SOFTWARE VIA A
  13 C   LOGICAL UNIT NUMBER, IT READS BUFR MESSAGES DIRECTLY FROM A MEMORY
  14 C   ARRAY WITHIN THE APPLICATION PROGRAM ITSELF.  THIS PROVIDES USERS
  15 C   WITH GREATER FLEXIBILITY FROM AN INPUT/OUTPUT PERSPECTIVE.
  16 C   READERME CAN BE USED IN ANY CONTEXT IN WHICH READMG MIGHT OTHERWISE
  17 C   BE USED.  IF THIS MESSAGE IS NOT A BUFR MESSAGE, THEN AN
  18 C   APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT.
  19 C
  20 C PROGRAM HISTORY LOG:
  21 C 1995-06-28  J. WOOLLEN -- ORIGINAL AUTHOR (FOR ERS DATA)
  22 C 1997-07-29  J. WOOLLEN -- MODIFIED TO PROCESS GOES SOUNDINGS FROM
  23 C                           NESDIS
  24 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  25 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  26 C                           ROUTINE "BORT"; MODIFIED TO MAKE Y2K
  27 C                           COMPLIANT; IMPROVED MACHINE PORTABILITY
  28 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  29 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  30 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  31 C                           BUFR FILES UNDER THE MPI); INCREASED THE
  32 C                           MAXIMUM NUMBER OF POSSIBLE DESCRIPTORS IN A
  33 C                           SUBSET FROM 1000 TO 3000
  34 C 2000-09-19  J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD
  35 C                           BEEN REPLICATED IN THIS AND OTHER READ
  36 C                           ROUTINES AND CONSOLIDATED IT INTO A NEW
  37 C                           ROUTINE CKTABA, CALLED HERE, WHICH IS
  38 C                           ENHANCED TO ALLOW COMPRESSED AND STANDARD
  39 C                           BUFR MESSAGES TO BE READ (ROUTINE UNCMPS,
  40 C                           WHICH HAD BEEN CALLED BY THIS AND OTHER
  41 C                           ROUTINES IS NOW OBSOLETE AND HAS BEEN
  42 C                           REMOVED FROM THE BUFRLIB; MAXIMUM MESSAGE
  43 C                           LENGTH INCREASED FROM 10,000 TO 20,000
  44 C                           BYTES
  45 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  46 C                           INTERDEPENDENCIES
  47 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  48 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  49 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  50 C                           TERMINATES ABNORMALLY
  51 C 2004-08-18  J. ATOR    -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY
  52 C                           TO EBCDIC MACHINES; MAXIMUM MESSAGE LENGTH
  53 C                           INCREASED FROM 20,000 TO 50,000 BYTES
  54 C 2005-11-29  J. ATOR    -- USE ICHKSTR
  55 C 2009-03-23  D. KEYSER  -- CALL BORT IN CASE OF MBAY OVERFLOW
  56 C 2009-03-23  J. ATOR    -- ADD LOGIC TO ALLOW SECTION 3 DECODING;
  57 C                           ADD LOGIC TO PROCESS DICTIONARY MESSAGES
  58 C 2012-06-07  J. ATOR    -- DON'T RESPOND TO DX TABLE MESSAGES IF
  59 C                           SECTION 3 DECODING IS BEING USED
  60 C
  61 C USAGE:    CALL READERME (MESG, LUNIT, SUBSET, JDATE, IRET)
  62 C   INPUT ARGUMENT LIST:
  63 C     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
  64 C                MESSAGE
  65 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  66 C
  67 C   OUTPUT ARGUMENT LIST:
  68 C     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
  69 C                BEING READ
  70 C     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
  71 C                MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR
  72 C                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
  73 C     IRET     - INTEGER: RETURN CODE:
  74 C                       0 = normal return
  75 C                      -1 = unrecognized Table A message type
  76 C                      11 = this is a BUFR table (dictionary) message
  77 C
  78 C REMARKS:
  79 C    THIS ROUTINE CALLS:        BORT     CKTABA   DXINIT   ERRWRT
  80 C                               ICHKSTR  IDXMSG   IUPBS3   LMSG
  81 C                               MAKESTAB READS3   STATUS   STBFDX
  82 C                               WTSTAT
  83 C    THIS ROUTINE IS CALLED BY: None
  84 C                               Normally called only by application
  85 C                               programs.
  86 C
  87 C ATTRIBUTES:
  88 C   LANGUAGE: FORTRAN 77
  89 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  90 C
  91 C$$$
  92
  93       INCLUDE 'bufrlib.prm'
  94
  95       COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES)
  96       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  97      .                MBAY(MXMSGLD4,NFILES)
  98       COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  99       COMMON /QUIET/  IPRT
 100
 101       CHARACTER*128 BORT_STR,ERRSTR
 102       CHARACTER*8 SUBSET,SEC0,TAMNEM
 103       CHARACTER*1 CEC0(8)
 104
 105       DIMENSION   MESG(*),IEC0(2)
 106
 107       DIMENSION   IDRDM(NFILES)
 108
 109       LOGICAL ENDTBL
 110
 111       EQUIVALENCE (SEC0,IEC0,CEC0)
 112
 113       DATA IDRDM/NFILES*0/
 114       SAVE IDRDM
 115
 116 C-----------------------------------------------------------------------
 117 C-----------------------------------------------------------------------
 118
 119       IRET = 0
 120
 121 C  CHECK THE FILE STATUS
 122 C  ---------------------
 123
 124       CALL STATUS(LUNIT,LUN,IL,IM)
 125       IF(IL.EQ.0) GOTO 900
 126       IF(IL.GT.0) GOTO 901
 127       CALL WTSTAT(LUNIT,LUN,IL, 1)
 128
 129 C  COPY THE INPUT MESSAGE INTO THE INTERNAL MESSAGE BUFFER
 130 C  -------------------------------------------------------
 131
 132       IEC0(1) = MESG(1)
 133       IEC0(2) = MESG(2)
 134       LNMSG = LMSG(SEC0)
 135       IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 902
 136       DO I=1,LNMSG
 137         MBAY(I,LUN) = MESG(I)
 138       ENDDO
 139
 140 C     Confirm that the first 4 bytes of SEC0 contain 'BUFR' encoded in
 141 C     CCITT IA5 (i.e. ASCII).
 142
 143       IF(ICHKSTR('BUFR',CEC0,4).NE.0) GOTO 903
 144
 145 C  PARSE THE MESSAGE SECTION CONTENTS
 146 C  ----------------------------------
 147
 148       IF(ISC3(LUN).NE.0) CALL READS3(LUN)
 149
 150       CALL CKTABA(LUN,SUBSET,JDATE,IRET)
 151
 152       IF(ISC3(LUN).NE.0) RETURN
 153
 154 C  CHECK FOR A DX DICTIONARY MESSAGE
 155 C  ---------------------------------
 156
 157 C     A new DX dictionary table can be passed in as a consecutive set of
 158 C     DX dictionary messages.  Each message should be passed in one at a
 159 C     time, via input argument MESG during consecutive calls to this
 160 C     subroutine, and will be processed as a single dictionary table up
 161 C     until the next message is passed in which either contains no data
 162 C     subsets or else is a non-DX dictionary message.
 163
 164       ENDTBL = .FALSE.
 165
 166       IF(IDXMSG(MBAY(1,LUN)).EQ.1) THEN
 167
 168 C       This is a DX dictionary message that was generated by the
 169 C       BUFRLIB archive library software.
 170
 171         IF(IUPBS3(MBAY(1,LUN),'NSUB').EQ.0) THEN
 172
 173 C         But it doesn't contain any actual dictionary information, so
 174 C         assume we've reached the end of the dictionary table.
 175
 176           IF(IDRDM(LUN).GT.0) THEN
 177             ENDTBL = .TRUE.
 178           ENDIF
 179         ELSE
 180           IF(IDRDM(LUN).EQ.0) THEN
 181
 182 C           This is the first DX dictionary message that is part of a
 183 C           new dictionary table.
 184
 185             CALL DXINIT(LUN,0)
 186           ENDIF
 187           IDRDM(LUN) = IDRDM(LUN) + 1
 188           CALL STBFDX(LUN,MBAY(1,LUN))
 189         ENDIF
 190       ELSE IF(IDRDM(LUN).GT.0) THEN
 191
 192 C       This is the first non-DX dictionary message received following a
 193 C       string of DX dictionary messages, so assume we've reached the
 194 C       end of the dictionary table.
 195
 196         ENDTBL = .TRUE.
 197       ENDIF
 198
 199       IF(ENDTBL) THEN
 200         IF ( IPRT .GE. 2 ) THEN
 201         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 202         WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' )
 203      .    'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (',
 204      .    IDRDM(LUN), ') MESSAGES;'
 205         CALL ERRWRT(ERRSTR)
 206         ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA '//
 207      .    'MESSAGES UNTIL NEXT DX TABLE IS PASSED IN'
 208         CALL ERRWRT(ERRSTR)
 209         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 210         CALL ERRWRT(' ')
 211         ENDIF
 212         IDRDM(LUN) = 0
 213         CALL MAKESTAB
 214       ENDIF
 215
 216 C  EXITS
 217 C  -----
 218
 219       RETURN
 220 900   CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT '//
 221      . 'MUST BE OPEN FOR INPUT')
 222 901   CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR '//
 223      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 224 902   WRITE(BORT_STR,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH",
 225      . 1X,I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")')
 226      . LNMSG*NBYTW,MXMSGL
 227       CALL BORT(BORT_STR)
 228 903   CALL BORT('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD'//
 229      . ' NOT "BUFR", DOES NOT CONTAIN BUFR DATA')
 230       END