var/external/bufr/rdmemm.f

   1       SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDMEMM
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM
   9 C   INTERNAL MEMORY (ARRAY MSGS IN COMMON BLOCK /MSGMEM/) INTO A
  10 C   MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/).  IT IS
  11 C   IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMM EXCEPT IT DOES
  12 C   NOT ADVANCE THE VALUE OF IMSG PRIOR TO RETURNING TO CALLING
  13 C   PROGRAM.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  17 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  18 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  19 C                           ROUTINE "BORT"; MODIFIED TO MAKE Y2K
  20 C                           COMPLIANT
  21 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  22 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  23 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  24 C                           BUFR FILES UNDER THE MPI); THE MAXIMUM
  25 C                           NUMBER OF BYTES REQUIRED TO STORE ALL
  26 C                           MESSAGES INTERNALLY WAS INCREASED FROM 4
  27 C                           MBYTES TO 8 MBYTES
  28 C 2000-09-19  J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD
  29 C                           BEEN REPLICATED IN THIS AND OTHER READ
  30 C                           ROUTINES AND CONSOLIDATED IT INTO A NEW
  31 C                           ROUTINE CKTABA, CALLED HERE, WHICH IS
  32 C                           ENHANCED TO ALLOW COMPRESSED AND STANDARD
  33 C                           BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE
  34 C                           LENGTH INCREASED FROM 10,000 TO 20,000
  35 C                           BYTES
  36 C 2001-08-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  37 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  38 C                           INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
  39 C                           16 MBYTES
  40 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  41 C                           INTERDEPENDENCIES
  42 C 2003-11-04  D. KEYSER  -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
  43 C                           BUFR MESSAGES WHICH CAN BE STORED
  44 C                           INTERNALLY) INCREASED FROM 50000 TO 200000;
  45 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  46 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  47 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  48 C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  49 C                           HAPPEN
  50 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  51 C                           20,000 TO 50,000 BYTES
  52 C 2004-11-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  53 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  54 C                           INTERNALLY) WAS INCREASED FROM 16 MBYTES TO
  55 C                           50 MBYTES
  56 C 2009-03-23  J. ATOR    -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE
  57 C                           (DICTIONARY) MESSAGES; USE ERRWRT
  58 C
  59 C
  60 C USAGE:    CALL RDMEMM (IMSG, SUBSET, JDATE, IRET)
  61 C   INPUT ARGUMENT LIST:
  62 C     IMSG     - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN
  63 C                STORAGE
  64 C
  65 C   OUTPUT ARGUMENT LIST:
  66 C     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
  67 C                BEING READ
  68 C     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
  69 C                MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR
  70 C                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
  71 C     IRET     - INTEGER: RETURN CODE:
  72 C                       0 = normal return
  73 C                      -1 = IMSG is either zero or greater than the
  74 C                           number of messages in memory
  75 C
  76 C REMARKS:
  77 C    NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR
  78 C    MESSAGES INTO INTERNAL MEMORY.
  79 C
  80 C    THIS ROUTINE CALLS:        BORT     CKTABA   DXINIT   ERRWRT
  81 C                               MAKESTAB STATUS   STBFDX   WTSTAT
  82 C    THIS ROUTINE IS CALLED BY: READMM   UFBMMS   UFBRMS   UFBTAM
  83 C                               Also called by application programs.
  84 C
  85 C ATTRIBUTES:
  86 C   LANGUAGE: FORTRAN 77
  87 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  88 C
  89 C$$$
  90
  91       INCLUDE 'bufrlib.prm'
  92
  93       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  94      .                INODE(NFILES),IDATE(NFILES)
  95       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  96      .                MBAY(MXMSGLD4,NFILES)
  97       COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
  98      .                MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
  99      .                IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
 100       COMMON /QUIET / IPRT
 101
 102       DIMENSION     MSGDX(MXMSGLD4)
 103
 104       CHARACTER*128 BORT_STR,ERRSTR
 105       CHARACTER*8   SUBSET
 106
 107       LOGICAL KNOWN
 108
 109 C-----------------------------------------------------------------------
 110 C-----------------------------------------------------------------------
 111
 112 C  CHECK THE MESSAGE REQUEST AND FILE STATUS
 113 C  -----------------------------------------
 114
 115       CALL STATUS(MUNIT,LUN,IL,IM)
 116       CALL WTSTAT(MUNIT,LUN,IL, 1)
 117       IF(IL.EQ.0) GOTO 900
 118       IF(IL.GT.0) GOTO 901
 119       IRET = 0
 120
 121       IF(IMSG.EQ.0 .OR.IMSG.GT.MSGP(0)) THEN
 122          CALL WTSTAT(MUNIT,LUN,IL,0)
 123          IF(IPRT.GE.1) THEN
 124       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 125             IF(IMSG.EQ.0)  THEN
 126                ERRSTR = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '//
 127      .          'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '//
 128      .          'IRET = -1'
 129             ELSE
 130                WRITE ( UNIT=ERRSTR, FMT='(A,I6,A,I6,A)' )
 131      .          'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', IMSG,
 132      .          ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (',
 133      .          MSGP(0), '), RETURN WITH IRET = -1'
 134             ENDIF
 135             CALL ERRWRT(ERRSTR)
 136       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 137       CALL ERRWRT(' ')
 138          ENDIF
 139          IRET = -1
 140          GOTO 100
 141       ENDIF
 142
 143 C  ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE
 144 C  ---------------------------------------------------
 145
 146 C     Determine which table applies to this message.
 147
 148       KNOWN = .FALSE.
 149       JJ = NDXTS
 150       DO WHILE ((.NOT.KNOWN).AND.(JJ.GE.1))
 151          IF (IPMSGS(JJ).LE.IMSG) THEN
 152             KNOWN = .TRUE.
 153          ELSE
 154             JJ = JJ - 1
 155          ENDIF
 156       ENDDO
 157       IF (.NOT.KNOWN) GOTO 902
 158
 159 C     Is this table the one that is currently in scope?
 160
 161       IF (JJ.NE.LDXTS) THEN
 162
 163 C        No, so reset the software to use the proper table.
 164
 165          IF(IPRT.GE.2) THEN
 166             CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++')
 167             WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A,I6)' )
 168      .        'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', JJ,
 169      .        ' INSTEAD OF DX TABLE #', LDXTS,
 170      .        ' FOR REQUESTED MESSAGE #', IMSG
 171             CALL ERRWRT(ERRSTR)
 172             CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++')
 173             CALL ERRWRT(' ')
 174          ENDIF
 175          CALL DXINIT(LUN,0)
 176
 177 C        Store each of the DX dictionary messages which constitute
 178 C        this table.
 179
 180          DO II = IFDXTS(JJ), (IFDXTS(JJ)+ICDXTS(JJ)-1)
 181             IF (II.EQ.NDXM) THEN
 182                NWRD = LDXM - IPDXM(II) + 1
 183             ELSE
 184                NWRD = IPDXM(II+1) - IPDXM(II)
 185             ENDIF
 186             DO KK = 1, NWRD
 187                MSGDX(KK) = MDX(IPDXM(II)+KK-1)
 188             ENDDO
 189             CALL STBFDX(LUN,MSGDX)
 190          ENDDO
 191
 192 C        Rebuild the internal jump/link table.
 193
 194          CALL MAKESTAB
 195          LDXTS = JJ
 196       ENDIF
 197
 198 C  READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER
 199 C  -----------------------------------------------------
 200
 201       IPTR = MSGP(IMSG)
 202       IF(IMSG.LT.MSGP(0)) LPTR = MSGP(IMSG+1)-IPTR
 203       IF(IMSG.EQ.MSGP(0)) LPTR = MLAST-IPTR+1
 204       IPTR = IPTR-1
 205
 206       DO I=1,LPTR
 207          MBAY(I,LUN) = MSGS(IPTR+I)
 208       ENDDO
 209
 210 C  PARSE THE MESSAGE SECTION CONTENTS
 211 C  ----------------------------------
 212
 213       CALL CKTABA(LUN,SUBSET,JDATE,JRET)
 214       NMSG(LUN) = IMSG
 215
 216 C  EXITS
 217 C  -----
 218
 219 100   RETURN
 220 900   CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '//
 221      . 'MUST BE OPEN FOR INPUT')
 222 901   CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '//
 223      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 224 902   WRITE(BORT_STR,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '//
 225      . 'REQUESTED MESSAGE #",I5)') IMSG
 226       CALL BORT(BORT_STR)
 227       END