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