var/external/bufr/dumpbf.f

   1       SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    DUMPBF
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1996-12-11
   7 C
   8 C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST
   9 C   TWO NON-DICTIONARY BUFR MESSAGES IN LOGICAL UNIT LUNIT WHICH
  10 C   CONTAIN ZERO SUBSETS.  NORMALLY, THESE "DUMMY" MESSAGES APPEAR
  11 C   ONLY IN DATA DUMP FILES AND ARE IMMEDIATELY AFTER THE DICTIONARY
  12 C   MESSAGES.  THEY CONTAIN A DUMP "CENTER TIME" AND A DUMP FILE
  13 C   "PROCESSING TIME", RESPECTIVELY.  LUNIT SHOULD NOT BE PREVIOUSLY
  14 C   OPENED TO THE BUFR INTERFACE.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 1996-12-11  J. WOOLLEN -- ORIGINAL AUTHOR
  18 C 1996-12-17  J. WOOLLEN -- CORRECTED ERROR IN DUMP DATE READER
  19 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 C                           ROUTINE "BORT"; MODIFIED TO MAKE Y2K
  22 C                           COMPLIANT
  23 C 2003-05-19  M. SHIREY  -- REPLACED CALLS TO FORTRAN INSRINSIC
  24 C                           FUNCTION ICHAR WITH THE NCEP W3LIB C-
  25 C                           FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK
  26 C                           PROPERLY ON SOME MACHINES (E.G., IBM FROST/
  27 C                           SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS
  28 C                           ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION)
  29 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  30 C                           INTERDEPENDENCIES
  31 C 2003-11-04  D. KEYSER  -- MODIFIED DATE CALCULATIONS TO NO LONGER
  32 C                           USE FLOATING POINT ARITHMETIC SINCE THIS
  33 C                           CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER
  34 C                           RESULTING DATE ON SOME MACHINES (E.G., NCEP
  35 C                           IBM FROST/SNOW), INCREASES PORTABILITY;
  36 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  37 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  38 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  39 C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  40 C                           HAPPEN
  41 C 2004-08-18  J. ATOR    -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY
  42 C                           TO EBCDIC MACHINES
  43 C 2004-12-20  D. KEYSER  -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE
  44 C                           INFORMATION (IN CASE IT HAS NOT YET BEEN
  45 C                           CALLED), THIS ROUTINE DOES NOT REQUIRE IT
  46 C                           BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES
  47 C                           THAT DO REQUIRE IT
  48 C 2005-11-29  J. ATOR    -- USE IUPBS01, IGETDATE, GETLENS AND RDMSGW
  49 C 2009-03-23  J. ATOR    -- USE IDXMSG, IUPBS3 AND ERRWRT
  50 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  51 C                           USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE
  52 C                           THE C FILE WITHOUT CLOSING THE FORTRAN FILE
  53 C
  54 C USAGE:    CALL DUMPBF (LUNIT, JDATE, JDUMP)
  55 C   INPUT ARGUMENT LIST:
  56 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  57 C
  58 C   OUTPUT ARGUMENT LIST:
  59 C     JDATE    - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR
  60 C                (YYYY OR YY, DEPENDING ON DATELEN() VALUE),
  61 C                MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE
  62 C                FIRST NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS
  63 C                (NORMALLY THE DATA DUMP CENTER TIME IN A DATA DUMP
  64 C                FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED
  65 C     JDUMP    - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR
  66 C                (YYYY OR YY, DEPENDING ON DATELEN() VALUE),
  67 C                MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE
  68 C                SECOND NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS
  69 C                (NORMALLY THE FILE PROCESSING TIME IN A DATA DUMP
  70 C                FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED
  71 C
  72 C   INPUT FILES:
  73 C     UNIT "LUNIT" - BUFR FILE
  74 C
  75 C REMARKS:
  76 C    THIS ROUTINE CALLS:        BORT     ERRWRT   IDXMSG   IGETDATE
  77 C                               IUPBS01  IUPBS3   RDMSGW   STATUS
  78 C                               WRDLEN
  79 C    THIS ROUTINE IS CALLED BY: None
  80 C                               Normally called only by application
  81 C                               programs.
  82 C
  83 C ATTRIBUTES:
  84 C   LANGUAGE: FORTRAN 77
  85 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  86 C
  87 C$$$
  88
  89       INCLUDE 'bufrlib.prm'
  90
  91       COMMON /QUIET / IPRT
  92
  93       DIMENSION     MBAY(MXMSGLD4)
  94       DIMENSION     JDATE(5),JDUMP(5)
  95
  96       CHARACTER*128 ERRSTR
  97
  98 C-----------------------------------------------------------------------
  99 C-----------------------------------------------------------------------
 100
 101 C  CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION
 102 C  ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED)
 103 C  ---------------------------------------------------------------
 104
 105       CALL WRDLEN
 106
 107       DO I=1,5
 108         JDATE(I) = -1
 109         JDUMP(I) = -1
 110       ENDDO
 111
 112 C  SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO)
 113 C  -----------------------------------------------------------
 114
 115       CALL STATUS(LUNIT,LUN,JL,JM)
 116       IF(JL.NE.0) GOTO 900
 117       call openbf(lunit,'INX',lunit)
 118
 119 C  READ PAST ANY DICTIONARY MESSAGES
 120 C  ---------------------------------
 121
 122 1     CALL RDMSGW(LUNIT,MBAY,IER)
 123       IF(IER.LT.0) GOTO 200
 124       IF(IDXMSG(MBAY).EQ.1) GOTO 1
 125
 126 C  DUMP CENTER YY,MM,DD,HH,MM IS IN THE FIRST EMPTY MESSAGE
 127 C  --------------------------------------------------------
 128 C  i.e. the first message containing zero subsets
 129
 130       IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200
 131
 132       IGD = IGETDATE(MBAY,JDATE(1),JDATE(2),JDATE(3),JDATE(4))
 133       JDATE(5) = IUPBS01(MBAY,'MINU')
 134
 135 C  DUMP CLOCK YY,MM,DD,HH,MM IS IN THE SECOND EMPTY MESSAGE
 136 C  --------------------------------------------------------
 137 C  i.e. the second message containing zero subsets
 138
 139       CALL RDMSGW(LUNIT,MBAY,IER)
 140       IF(IER.LT.0) GOTO 200
 141
 142       IF(IUPBS3(MBAY,'NSUB').NE.0) GOTO 200
 143
 144       IGD = IGETDATE(MBAY,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4))
 145       JDUMP(5) = IUPBS01(MBAY,'MINU')
 146
 147       call closbf(lunit)
 148       GOTO 100
 149
 150 200   IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN
 151       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 152       IF(JDATE(1).EQ.-1) THEN
 153         ERRSTR = 'BUFRLIB: DUMPBF - FIRST  EMPTY BUFR MESSAGE '//
 154      .    'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '//
 155      .    'JDATE = 4*-1'
 156         CALL ERRWRT(ERRSTR)
 157       ENDIF
 158       IF(JDUMP(1).EQ.-1) THEN
 159         ERRSTR = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE '//
 160      .    'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '//
 161      .    'JDUMP = 4*-1'
 162         CALL ERRWRT(ERRSTR)
 163       ENDIF
 164       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 165       CALL ERRWRT(' ')
 166       ENDIF
 167
 168 C  EXITS
 169 C  -----
 170
 171 100   RETURN
 172 900   CALL BORT
 173      . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
 174       END