var/external/bufr/rdbfdx.f

   1       SUBROUTINE RDBFDX(LUNIT,LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDBFDX
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT,
   9 C   THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE
  10 C   ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO INTERNAL MEMORY ARRAYS
  11 C   IN COMMON /TABABD/.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  15 C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  16 C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  17 C 1996-12-17  J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF
  18 C                           INTERNAL READS (INCREASES PORTABILITY)
  19 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 C                           ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
  22 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  23 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  24 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  25 C                           BUFR FILES UNDER THE MPI)
  26 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  27 C                           10,000 TO 20,000 BYTES
  28 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  29 C                           INTERDEPENDENCIES
  30 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  31 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  32 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  33 C                           TERMINATES ABNORMALLY
  34 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  35 C                           20,000 TO 50,000 BYTES
  36 C 2005-11-29  J. ATOR    -- USE GETLENS, IUPBS01 AND RDMSGW
  37 C 2009-03-23  J. ATOR    -- USE STNTBIA; MODIFY LOGIC TO HANDLE BUFR
  38 C                           TABLE MESSAGES ENCOUNTERED ANYWHERE IN THE
  39 C                           FILE (AND NOT JUST AT THE BEGINNING!)
  40 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  41 C                           REPLACE FORTRAN BACKSPACE WITH C BACKBUFR
  42 C
  43 C USAGE:    CALL RDBFDX (LUNIT, LUN)
  44 C   INPUT ARGUMENT LIST:
  45 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  46 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  47 C                (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT)
  48 C
  49 C   INPUT FILES:
  50 C     UNIT "LUNIT" - BUFR FILE
  51 C
  52 C REMARKS:
  53 C
  54 C   THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY
  55 C   SUBROUTINE RDUSDX, EXCEPT THAT RDUSDX READS FROM A FILE CONTAINING
  56 C   A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT.  SEE THE
  57 C   DOCBLOCK IN RDUSDX FOR A DESCRIPTION OF THE ARRAYS THAT ARE FILLED
  58 C   IN COMMON BLOCK /TABABD/.
  59 C
  60 C   THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY
  61 C   SUBROUTINE CPDXMM, EXCEPT THAT CPDXMM WRITES TO THE INTERNAL MEMORY
  62 C   ARRAYS IN COMMON BLOCK /MSGMEM/, FOR USE WITH A FILE OF BUFR
  63 C   MESSAGES THAT IS BEING READ AND STORED INTO INTERNAL MEMORY BY
  64 C   BUFR ARCHIVE LIBRARY SUBROUTINE UFBMEM.
  65 C
  66 C    THIS ROUTINE CALLS:        BORT     DXINIT   ERRWRT   IDXMSG
  67 C                               IUPBS3   MAKESTAB RDMSGW   STBFDX
  68 C                               BACKBUFR
  69 C    THIS ROUTINE IS CALLED BY: POSAPX   READDX   READMG
  70 C                               Normally not called by any application
  71 C                               programs.
  72 C
  73 C ATTRIBUTES:
  74 C   LANGUAGE: FORTRAN 77
  75 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  76 C
  77 C$$$
  78
  79         INCLUDE 'bufrlib.prm'
  80
  81         COMMON /QUIET/  IPRT
  82
  83         DIMENSION MBAY(MXMSGLD4)
  84
  85         CHARACTER*128 ERRSTR
  86
  87         LOGICAL DONE
  88
  89 C-----------------------------------------------------------------------
  90 C-----------------------------------------------------------------------
  91
  92         CALL DXINIT(LUN,0)
  93
  94         ICT = 0
  95         DONE = .FALSE.
  96
  97 C       Read a complete dictionary table from LUNIT, as a set of one or
  98 C       more DX dictionary messages.
  99
 100         DO WHILE ( .NOT. DONE )
 101           CALL RDMSGW ( LUNIT, MBAY, IER )
 102           IF ( IER .EQ. -1 ) THEN
 103
 104 C           Don't abort for an end-of-file condition, since it may be
 105 C           possible for a file to end with dictionary messages.
 106 C           Instead, backspace the file pointer and let the calling
 107 C           routine diagnose the end-of-file condition and deal with
 108 C           it as it sees fit.
 109
 110             call backbufr(lun)
 111             DONE = .TRUE.
 112           ELSE IF ( IER .EQ. -2 ) THEN
 113             GOTO 900
 114           ELSE IF ( IDXMSG(MBAY) .NE. 1 ) THEN
 115
 116 C           This is a non-DX dictionary message.  Assume we've reached
 117 C           the end of the dictionary table, and backspace LUNIT so that
 118 C           the next read (e.g. in the calling routine) will get this
 119 C           same message.
 120
 121             call backbufr(lun)
 122             DONE = .TRUE.
 123           ELSE IF ( IUPBS3(MBAY,'NSUB') .EQ. 0 ) THEN
 124
 125 C           This is a DX dictionary message, but it doesn't contain any
 126 C           actual dictionary information.  Assume we've reached the end
 127 C           of the dictionary table.
 128
 129             DONE = .TRUE.
 130           ELSE
 131
 132 C           Store this message into COMMON /TABABD/.
 133
 134             ICT = ICT + 1
 135             CALL STBFDX(LUN,MBAY)
 136           ENDIF
 137         ENDDO
 138
 139         IF ( IPRT .GE. 2 ) THEN
 140         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 141         WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' )
 142      .    'BUFRLIB: RDBFDX - STORED NEW DX TABLE CONSISTING OF (',
 143      .    ICT, ') MESSAGES;'
 144         CALL ERRWRT(ERRSTR)
 145         ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA IN '//
 146      .    'FILE UNTIL NEXT DX TABLE IS FOUND'
 147         CALL ERRWRT(ERRSTR)
 148         CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++')
 149         CALL ERRWRT(' ')
 150         ENDIF
 151
 152         CALL MAKESTAB
 153
 154         RETURN
 155  900    CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '//
 156      .    'MESSAGE')
 157         END