SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DUMPBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-12-11 C C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST C TWO NON-DICTIONARY BUFR MESSAGES IN LOGICAL UNIT LUNIT WHICH C CONTAIN ZERO SUBSETS. NORMALLY, THESE "DUMMY" MESSAGES APPEAR C ONLY IN DATA DUMP FILES AND ARE IMMEDIATELY AFTER THE DICTIONARY C MESSAGES. THEY CONTAIN A DUMP "CENTER TIME" AND A DUMP FILE C "PROCESSING TIME", RESPECTIVELY. LUNIT SHOULD NOT BE PREVIOUSLY C OPENED TO THE BUFR INTERFACE. C C PROGRAM HISTORY LOG: C 1996-12-11 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-12-17 J. WOOLLEN -- CORRECTED ERROR IN DUMP DATE READER C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC C FUNCTION ICHAR WITH THE NCEP W3LIB C- C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER C USE FLOATING POINT ARITHMETIC SINCE THIS C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER C RESULTING DATE ON SOME MACHINES (E.G., NCEP C IBM FROST/SNOW), INCREASES PORTABILITY; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY C TO EBCDIC MACHINES C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE C INFORMATION (IN CASE IT HAS NOT YET BEEN C CALLED), THIS ROUTINE DOES NOT REQUIRE IT C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES C THAT DO REQUIRE IT C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE, GETLENS AND RDMSGW C 2009-03-23 J. ATOR -- USE IDXMSG, IUPBS3 AND ERRWRT C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE C THE C FILE WITHOUT CLOSING THE FORTRAN FILE C C USAGE: CALL DUMPBF (LUNIT, JDATE, JDUMP) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C JDATE - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE C FIRST NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS C (NORMALLY THE DATA DUMP CENTER TIME IN A DATA DUMP C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED C JDUMP - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE C SECOND NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS C (NORMALLY THE FILE PROCESSING TIME IN A DATA DUMP C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE C IUPBS01 IUPBS3 RDMSGW STATUS C WRDLEN 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 /QUIET / IPRT DIMENSION MBAY(MXMSGLD4) DIMENSION JDATE(5),JDUMP(5) CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) C --------------------------------------------------------------- CALL WRDLEN DO I=1,5 JDATE(I) = -1 JDUMP(I) = -1 ENDDO C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) C ----------------------------------------------------------- CALL STATUS(LUNIT,LUN,JL,JM) IF(JL.NE.0) GOTO 900 call openbf(lunit,'INX',lunit) C READ PAST ANY DICTIONARY MESSAGES C --------------------------------- 1 CALL RDMSGW(LUNIT,MBAY,IER) IF(IER.LT.0) GOTO 200 IF(IDXMSG(MBAY).EQ.1) GOTO 1 C DUMP CENTER YY,MM,DD,HH,MM IS IN THE FIRST EMPTY MESSAGE C -------------------------------------------------------- C i.e. the first message containing zero subsets IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 IGD = IGETDATE(MBAY,JDATE(1),JDATE(2),JDATE(3),JDATE(4)) JDATE(5) = IUPBS01(MBAY,'MINU') C DUMP CLOCK YY,MM,DD,HH,MM IS IN THE SECOND EMPTY MESSAGE C -------------------------------------------------------- C i.e. the second message containing zero subsets CALL RDMSGW(LUNIT,MBAY,IER) IF(IER.LT.0) GOTO 200 IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200 IGD = IGETDATE(MBAY,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4)) JDUMP(5) = IUPBS01(MBAY,'MINU') call closbf(lunit) GOTO 100 200 IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') IF(JDATE(1).EQ.-1) THEN ERRSTR = 'BUFRLIB: DUMPBF - FIRST EMPTY BUFR MESSAGE '// . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// . 'JDATE = 4*-1' CALL ERRWRT(ERRSTR) ENDIF IF(JDUMP(1).EQ.-1) THEN ERRSTR = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE '// . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// . 'JDUMP = 4*-1' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') END