SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: UFBMEX
C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-01-26
C
C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH
C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY
C MSGS IN COMMON BLOCK /MSGMEM/). IF MESSAGES ARE APPENDED TO
C EXISTING MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS
C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. AN ARRAY IS
C ALSO RETURNED CONTAINING A LIST OF MESSAGE TYPES READ IN.
C
C THIS IS A VARIATION OF UFBMEM WHICH ENABLES MESSAGE SORTING BEFORE
C READING. BECAUSE OF THIS RE-ORDERING, EMBEDDED TABLE MESSAGES ARE
C NOT STORED IN COMMON /MSGMEM/, SINCE THEY ARE NO LONGER RELEVANT
C ONCE THE RE-ORDERING (I.E. SORTING) HAS TAKEN PLACE. INSTEAD, A
C SEPARATE UNIT NUMBER IS ADDED TO THE INPUT ARGUMENTS TO SPECIFY
C WHERE THE NECESSARY BUFR TABLE INFORMATION CAN BE FOUND.
C
C PROGRAM HISTORY LOG:
C 2012-01-26 J. WOOLLEN -- MODIFIED UFBMEM TO READ AND SORT MEMORY
C MESSAGES FOR TRANJB INGEST ROUTINES AND
C RETURN A LIST OF MESSAGE TYPES READ IN.
C ALSO, A SEPARATE INPUT ARGUMENT IS ADDED
C TO SPECIFY WHERE TO FIND THE BUFR TABLE,
C INSTEAD OF SAVING EMBEDDED DICTIONARY
C MESSAGES IN COMMON /MSGMEM/
C
C USAGE: CALL UFBMEX (LUNIT, LUNDX, INEW, IRET, MESG)
C INPUT ARGUMENT LIST:
C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER-
C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT
C INEW - INTEGER: SWITCH:
C 0 = initialize internal arrays prior to
C transferring messages here
C else = append the messages transferred here to
C internal memory arrays
C
C OUTPUT ARGUMENT LIST:
C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED
C MESG - INTEGER: ARRAY OF MESSAGE TYPES READ INTO MEMORY
C
C INPUT FILES:
C UNIT "LUNIT" - BUFR FILE
C UNIT "LUNDX" - BUFR DICTIONARY TABLE IN CHARACTER FORMAT
C
C REMARKS:
C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB
C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES
C FROM INTERNAL MEMORY.
C
C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IUPBS01
C NMWRD OPENBF RDMSGW
C THIS ROUTINE IS CALLED BY: None
C Normally called only by application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
. MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
. IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
CHARACTER*128 BORT_STR,ERRSTR
DIMENSION MBAY(MXMSGLD4)
INTEGER MESG(MAXMSG)
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE
C ----------------------------------------------------------
CALL OPENBF(LUNIT,'IN',LUNDX)
IF(INEW.EQ.0) THEN
MSGP(0) = 0
MUNIT = 0
MLAST = 0
NDXTS = 0
LDXTS = 0
NDXM = 0
LDXM = 0
ENDIF
NMSG = MSGP(0)
IRET = 0
IFLG = 0
ITIM = 0
C SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING
C ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE.
NDXTS = 1
LDXTS = 1
IPMSGS(1) = 1
C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS
C ------------------------------------------------------------
1 CALL RDMSGW(LUNIT,MBAY,IER)
IF(IER.EQ.-1) GOTO 100
IF(IER.EQ.-2) GOTO 900
NMSG = NMSG+1
MESG(NMSG) = IUPBS01(MBAY,'MTYP')
IF(NMSG .GT.MAXMSG) IFLG = 1
LMEM = NMWRD(MBAY)
IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2
IF(IFLG.EQ.0) THEN
IRET = IRET+1
DO I=1,LMEM
MSGS(MLAST+I) = MBAY(I)
ENDDO
MSGP(0) = NMSG
MSGP(NMSG) = MLAST+1
ELSE
IF(ITIM.EQ.0) THEN
MLAST0 = MLAST
ITIM=1
ENDIF
ENDIF
MLAST = MLAST+LMEM
GOTO 1
C EXITS
C -----
100 IF(IFLG.EQ.1) THEN
C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW
C --------------------------------------------------
IF(IPRT.GE.0) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
. 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ',
. 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG,
. ') - INCOMPLETE READ'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
. '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
. '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
CALL ERRWRT(ERRSTR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
MLAST=MLAST0
ENDIF
IF(IFLG.EQ.2) THEN
C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW
C --------------------------------------------------
IF(IPRT.GE.0) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' )
. 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ',
. 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM,
. ') - INCOMPLETE READ'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
. '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
. '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<'
CALL ERRWRT(ERRSTR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
MLAST=MLAST0
ENDIF
IF(IRET.EQ.0) THEN
CALL CLOSBF(LUNIT)
ELSE
IF(MUNIT.NE.0) CALL CLOSBF(LUNIT)
IF(MUNIT.EQ.0) MUNIT = LUNIT
ENDIF
IUNIT = MUNIT
C EXITS
C -----
RETURN
900 WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '//
. 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT
CALL BORT(BORT_STR)
END