var/external/bufr/ufbmex.f

   1       SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBMEX
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2012-01-26
   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.  AN ARRAY IS
  13 C   ALSO RETURNED CONTAINING A LIST OF MESSAGE TYPES READ IN.
  14 C
  15 C   THIS IS A VARIATION OF UFBMEM WHICH ENABLES MESSAGE SORTING BEFORE
  16 C   READING.  BECAUSE OF THIS RE-ORDERING, EMBEDDED TABLE MESSAGES ARE
  17 C   NOT STORED IN COMMON /MSGMEM/, SINCE THEY ARE NO LONGER RELEVANT
  18 C   ONCE THE RE-ORDERING (I.E. SORTING) HAS TAKEN PLACE.  INSTEAD, A
  19 C   SEPARATE UNIT NUMBER IS ADDED TO THE INPUT ARGUMENTS TO SPECIFY
  20 C   WHERE THE NECESSARY BUFR TABLE INFORMATION CAN BE FOUND.
  21 C
  22 C PROGRAM HISTORY LOG:
  23 C 2012-01-26  J. WOOLLEN -- MODIFIED UFBMEM TO READ AND SORT MEMORY
  24 C                           MESSAGES FOR TRANJB INGEST ROUTINES AND
  25 C                           RETURN A LIST OF MESSAGE TYPES READ IN.
  26 C                           ALSO, A SEPARATE INPUT ARGUMENT IS ADDED
  27 C                           TO SPECIFY WHERE TO FIND THE BUFR TABLE,
  28 C                           INSTEAD OF SAVING EMBEDDED DICTIONARY
  29 C                           MESSAGES IN COMMON /MSGMEM/
  30 C
  31 C USAGE:    CALL UFBMEX (LUNIT, LUNDX, INEW, IRET, MESG)
  32 C   INPUT ARGUMENT LIST:
  33 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  34 C     LUNDX    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER-
  35 C                SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT
  36 C     INEW     - INTEGER: SWITCH:
  37 C                       0 = initialize internal arrays prior to
  38 C                           transferring messages here
  39 C                    else = append the messages transferred here to
  40 C                           internal memory arrays
  41 C
  42 C   OUTPUT ARGUMENT LIST:
  43 C     IRET     - INTEGER: NUMBER OF MESSAGES TRANSFERRED
  44 C     MESG     - INTEGER: ARRAY OF MESSAGE TYPES READ INTO MEMORY
  45 C
  46 C   INPUT FILES:
  47 C     UNIT "LUNIT" - BUFR FILE
  48 C     UNIT "LUNDX" - BUFR DICTIONARY TABLE IN CHARACTER FORMAT
  49 C
  50 C REMARKS:
  51 C    NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB
  52 C    OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES
  53 C    FROM INTERNAL MEMORY.
  54 C
  55 C    THIS ROUTINE CALLS:        BORT     CLOSBF   ERRWRT   IUPBS01
  56 C                               NMWRD    OPENBF   RDMSGW
  57 C    THIS ROUTINE IS CALLED BY: None
  58 C                               Normally called only by application
  59 C                               programs.
  60 C
  61 C ATTRIBUTES:
  62 C   LANGUAGE: FORTRAN 77
  63 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  64 C
  65 C$$$
  66
  67       INCLUDE 'bufrlib.prm'
  68
  69       COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
  70      .                MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
  71      .                IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
  72
  73       CHARACTER*128 BORT_STR,ERRSTR
  74       DIMENSION     MBAY(MXMSGLD4)
  75       INTEGER       MESG(MAXMSG)
  76
  77 C-----------------------------------------------------------------------
  78 C-----------------------------------------------------------------------
  79
  80 C  TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE
  81 C  ----------------------------------------------------------
  82
  83       CALL OPENBF(LUNIT,'IN',LUNDX)
  84
  85       IF(INEW.EQ.0) THEN
  86          MSGP(0) = 0
  87          MUNIT = 0
  88          MLAST = 0
  89          NDXTS = 0
  90          LDXTS = 0
  91          NDXM = 0
  92          LDXM = 0
  93       ENDIF
  94
  95       NMSG = MSGP(0)
  96       IRET = 0
  97       IFLG = 0
  98       ITIM = 0
  99
 100 C  SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING
 101 C  ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE.
 102
 103       NDXTS = 1
 104       LDXTS = 1
 105       IPMSGS(1) = 1
 106
 107 C  TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS
 108 C  ------------------------------------------------------------
 109
 110 1     CALL RDMSGW(LUNIT,MBAY,IER)
 111       IF(IER.EQ.-1) GOTO 100
 112       IF(IER.EQ.-2) GOTO 900
 113
 114       NMSG = NMSG+1
 115       MESG(NMSG) = IUPBS01(MBAY,'MTYP')
 116       IF(NMSG      .GT.MAXMSG) IFLG = 1
 117       LMEM = NMWRD(MBAY)
 118       IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2
 119
 120       IF(IFLG.EQ.0) THEN
 121          IRET = IRET+1
 122          DO I=1,LMEM
 123             MSGS(MLAST+I) = MBAY(I)
 124          ENDDO
 125          MSGP(0)    = NMSG
 126          MSGP(NMSG) = MLAST+1
 127       ELSE
 128          IF(ITIM.EQ.0) THEN
 129             MLAST0 = MLAST
 130             ITIM=1
 131          ENDIF
 132       ENDIF
 133       MLAST = MLAST+LMEM
 134       GOTO 1
 135
 136 C  EXITS
 137 C  -----
 138
 139 100   IF(IFLG.EQ.1) THEN
 140
 141 C  EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW
 142 C  --------------------------------------------------
 143
 144       IF(IPRT.GE.0) THEN
 145       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 146       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
 147      . 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ',
 148      . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG,
 149      . ') - INCOMPLETE READ'
 150       CALL ERRWRT(ERRSTR)
 151       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 152      . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
 153       CALL ERRWRT(ERRSTR)
 154       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 155      . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
 156       CALL ERRWRT(ERRSTR)
 157       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 158       CALL ERRWRT(' ')
 159       ENDIF
 160       MLAST=MLAST0
 161       ENDIF
 162
 163       IF(IFLG.EQ.2) THEN
 164
 165 C  EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW
 166 C  --------------------------------------------------
 167
 168       IF(IPRT.GE.0) THEN
 169       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 170       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
 171      . 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ',
 172      . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM,
 173      . ') - INCOMPLETE READ'
 174       CALL ERRWRT(ERRSTR)
 175       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 176      . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
 177       CALL ERRWRT(ERRSTR)
 178       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 179      . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
 180       CALL ERRWRT(ERRSTR)
 181       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 182       CALL ERRWRT(' ')
 183       ENDIF
 184       MLAST=MLAST0
 185       ENDIF
 186
 187       IF(IRET.EQ.0) THEN
 188          CALL CLOSBF(LUNIT)
 189       ELSE
 190          IF(MUNIT.NE.0) CALL CLOSBF(LUNIT)
 191          IF(MUNIT.EQ.0) MUNIT = LUNIT
 192       ENDIF
 193       IUNIT = MUNIT
 194
 195 C  EXITS
 196 C  -----
 197
 198       RETURN
 199 900   WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '//
 200      . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT
 201       CALL BORT(BORT_STR)
 202       END