dumpbf.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1996-12-11
      
C> 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> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
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>
      SUBROUTINE dumpbf(LUNIT,JDATE,JDUMP)

      USE moda_mgwa

      COMMON /quiet / iprt

      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,mgwa,ier)
      IF(ier.LT.0) goto 200
      IF(idxmsg(mgwa).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(mgwa,'NSUB').NE.0) goto 200

      igd = igetdate(mgwa,jdate(1),jdate(2),jdate(3),jdate(4))
      jdate(5) = iupbs01(mgwa,'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,mgwa,ier)
      IF(ier.LT.0) goto 200
     
      IF(iupbs3(mgwa,'NSUB').NE.0) goto 200

      igd = igetdate(mgwa,jdump(1),jdump(2),jdump(3),jdump(4))
      jdump(5) = iupbs01(mgwa,'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