var/external/bufr/ufbmem.f

   1       SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBMEM
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH
   9 C   MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY
  10 C   MSGS IN COMMON BLOCK /MSGMEM/).  IF MESSAGES ARE APPENDED TO
  11 C   EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS
  12 C   CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM.
  13 C
  14 C PROGRAM HISTORY LOG:
  15 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  16 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  17 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  18 C                           ROUTINE "BORT"
  19 C 1999-11-18  J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO
  20 C                           STORE ALL MESSAGES INTERNALLY WAS INCREASED
  21 C                           FROM 4 MBYTES TO 8 MBYTES
  22 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  23 C                           10,000 TO 20,000 BYTES
  24 C 2001-08-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  25 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  26 C                           INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
  27 C                           16 MBYTES
  28 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  29 C                           INTERDEPENDENCIES
  30 C 2003-11-04  D. KEYSER  -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
  31 C                           BUFR MESSAGES WHICH CAN BE STORED
  32 C                           INTERNALLY) INCREASED FROM 50000 TO 200000;
  33 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  34 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  35 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  36 C                           TERMINATES ABNORMALLY
  37 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  38 C                           20,000 TO 50,000 BYTES
  39 C 2004-11-15  D. KEYSER  -- MODIFIED TO NOT ABORT WHEN THERE ARE EITHER
  40 C                           TOO MANY MESSAGES READ IN (I.E., .GT.
  41 C                           MAXMSG) OR TOO MANY BYTES READ IN (I.E.,
  42 C                           .GT. MAXMEM), BUT RATHER JUST STORE MAXMSG
  43 C                           MESSAGES OR MAXMEM BYTES AND PRINT A
  44 C                           DIAGNOSTIC; PARAMETER MAXMEM (THE MAXIMUM
  45 C                           NUMBER OF BYTES REQUIRED TO STORE ALL
  46 C                           MESSAGES INTERNALLY) WAS INCREASED FROM 16
  47 C                           MBYTES TO 50 MBYTES
  48 C 2005-11-29  J. ATOR    -- USE RDMSGW AND NMWRD
  49 C 2009-03-23  J. ATOR    -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE
  50 C                           (DICTIONARY) MESSAGES
  51 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  52 C                           CALL STATUS TO GET LUN; REPLACE FORTRAN
  53 C                           REWIND AND BACKSPACE WITH C ROUTINES CEWIND
  54 C                           AND BACKBUFR
  55 C
  56 C USAGE:    CALL UFBMEM (LUNIT, INEW, IRET, IUNIT)
  57 C   INPUT ARGUMENT LIST:
  58 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  59 C     INEW     - INTEGER: SWITCH:
  60 C                       0 = initialize internal arrays prior to
  61 C                           transferring messages here
  62 C                    else = append the messages transferred here to
  63 C                           internal memory arrays
  64 C
  65 C   OUTPUT ARGUMENT LIST:
  66 C     IRET     - INTEGER: NUMBER OF MESSAGES TRANSFERRED
  67 C     IUNIT    - INTEGER: RETURN CODE:
  68 C                       0 = no messages were read from LUNIT, file is
  69 C                           empty
  70 C                   LUNIT = INEW input as 0
  71 C                    else = FORTRAN logical unit for BUFR file
  72 C                           associated with initial message transferred
  73 C                           to internal memory
  74 C
  75 C   INPUT FILES:
  76 C     UNIT "LUNIT" - BUFR FILE
  77 C
  78 C REMARKS:
  79 C    NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB
  80 C    OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES
  81 C    FROM INTERNAL MEMORY.
  82 C
  83 C    THIS ROUTINE CALLS:        BORT     CLOSBF   CPDXMM   ERRWRT
  84 C                               IDXMSG   NMWRD    OPENBF   RDMSGW
  85 C                               STATUS   CEWIND   BACKBUFR
  86 C    THIS ROUTINE IS CALLED BY: None
  87 C                               Normally called only by application
  88 C                               programs.
  89 C
  90 C ATTRIBUTES:
  91 C   LANGUAGE: FORTRAN 77
  92 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  93 C
  94 C$$$
  95
  96       INCLUDE 'bufrlib.prm'
  97
  98       COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
  99      .                MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
 100      .                IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
 101
 102       CHARACTER*128 BORT_STR,ERRSTR
 103       DIMENSION     MBAY(MXMSGLD4)
 104
 105 C-----------------------------------------------------------------------
 106 C-----------------------------------------------------------------------
 107
 108 C  TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE
 109 C  ----------------------------------------------------------
 110
 111       CALL OPENBF(LUNIT,'IN',LUNIT)
 112
 113       IF(INEW.EQ.0) THEN
 114          MSGP(0) = 0
 115          MUNIT = 0
 116          MLAST = 0
 117          NDXTS = 0
 118          LDXTS = 0
 119          NDXM = 0
 120          LDXM = 0
 121       ENDIF
 122
 123       NMSG = MSGP(0)
 124       IRET = 0
 125       IFLG = 0
 126       ITIM = 0
 127
 128 C     Copy any BUFR dictionary table messages from the beginning of
 129 C     LUNIT into COMMON /MSGMEM/ for possible later use.  Note that
 130 C     such a table (if one exists) is already now in scope due to the
 131 C     prior call to subroutine OPENBF, which in turn would have
 132 C     automatically called subroutines READDX, RDBFDX and MAKESTAB
 133 C     for this table.
 134
 135       ITEMP = NDXTS
 136       CALL STATUS(LUNIT,LUN,IL,IM)
 137       CALL CEWIND(LUN)
 138       CALL CPDXMM(LUNIT)
 139
 140 C     If a table was indeed present at the beginning of the file,
 141 C     then set the flag to indicate that this table is now in scope.
 142
 143       IF ((ITEMP+1).EQ.NDXTS) LDXTS = NDXTS
 144
 145 C  TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS
 146 C  ------------------------------------------------------------
 147
 148 1     CALL RDMSGW(LUNIT,MBAY,IER)
 149       IF(IER.EQ.-1) GOTO 100
 150       IF(IER.EQ.-2) GOTO 900
 151
 152       IF(IDXMSG(MBAY).EQ.1) THEN
 153
 154 C       New "embedded" BUFR dictionary table messages have been found in
 155 C       this file.  Copy them into COMMON /MSGMEM/ for later use.
 156
 157         call backbufr(lun) !BACKSPACE LUNIT
 158         CALL CPDXMM(LUNIT)
 159         GOTO 1
 160       ENDIF
 161
 162       NMSG = NMSG+1
 163       IF(NMSG      .GT.MAXMSG) IFLG = 1
 164       LMEM = NMWRD(MBAY)
 165       IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2
 166
 167       IF(IFLG.EQ.0) THEN
 168          IRET = IRET+1
 169          DO I=1,LMEM
 170             MSGS(MLAST+I) = MBAY(I)
 171          ENDDO
 172          MSGP(0)    = NMSG
 173          MSGP(NMSG) = MLAST+1
 174       ELSE
 175          IF(ITIM.EQ.0) THEN
 176             MLAST0 = MLAST
 177             ITIM=1
 178          ENDIF
 179       ENDIF
 180       MLAST = MLAST+LMEM
 181       GOTO 1
 182
 183 C  EXITS
 184 C  -----
 185
 186 100   IF(IFLG.EQ.1) THEN
 187
 188 C  EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW
 189 C  --------------------------------------------------
 190
 191       IF(IPRT.GE.0) THEN
 192       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 193       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
 194      . 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ',
 195      . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG,
 196      . ') - INCOMPLETE READ'
 197       CALL ERRWRT(ERRSTR)
 198       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 199      . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
 200       CALL ERRWRT(ERRSTR)
 201       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 202      . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
 203       CALL ERRWRT(ERRSTR)
 204       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 205       CALL ERRWRT(' ')
 206       ENDIF
 207       MLAST=MLAST0
 208       ENDIF
 209
 210       IF(IFLG.EQ.2) THEN
 211
 212 C  EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW
 213 C  --------------------------------------------------
 214
 215       IF(IPRT.GE.0) THEN
 216       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 217       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
 218      . 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ',
 219      . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM,
 220      . ') - INCOMPLETE READ'
 221       CALL ERRWRT(ERRSTR)
 222       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 223      . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
 224       CALL ERRWRT(ERRSTR)
 225       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 226      . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
 227       CALL ERRWRT(ERRSTR)
 228       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 229       CALL ERRWRT(' ')
 230       ENDIF
 231       MLAST=MLAST0
 232       ENDIF
 233
 234       IF(IRET.EQ.0) THEN
 235          CALL CLOSBF(LUNIT)
 236       ELSE
 237          IF(MUNIT.NE.0) CALL CLOSBF(LUNIT)
 238          IF(MUNIT.EQ.0) MUNIT = LUNIT
 239       ENDIF
 240       IUNIT = MUNIT
 241
 242 C  EXITS
 243 C  -----
 244
 245       RETURN
 246 900   WRITE(BORT_STR,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE '//
 247      . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT
 248       CALL BORT(BORT_STR)
 249       END