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 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 OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: C THIS ROUTINE CALLS: BORT GETLENS IGETDATE IUPB C IUPBS01 RDMSGW STATUS 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) 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 C READ PAST ANY DICTIONARY MESSAGES C --------------------------------- REWIND LUNIT 1 CALL RDMSGW(LUNIT,MBAY,IER) IF(IER.LT.0) GOTO 200 IF(IUPBS01(MBAY,'MTYP').EQ.11) 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 CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5) IPT = LEN0+LEN1+LEN2+5 IF(IUPB(MBAY,IPT,16).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 CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5) IPT = LEN0+LEN1+LEN2+5 IF(IUPB(MBAY,IPT,16).NE.0) GOTO 200 IGD = IGETDATE(MBAY,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4)) JDUMP(5) = IUPBS01(MBAY,'MINU') GOTO 100 200 IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN PRINT* PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++' IF(JDATE(1).EQ.-1) PRINT*, 'BUFRLIB: DATEBF - FIRST EMPTY ', . 'BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN ', . 'WITH JDATE = 4*-1' IF(JDUMP(1).EQ.-1) PRINT*, 'BUFRLIB: DATEBF - SECOND EMPTY ', . 'BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN ', . 'WITH JDUMP = 4*-1' PRINT*,'+++++++++++++++++++++++WARNING+++++++++++++++++++++++++' PRINT* ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') END