wrfv2_fire/var/external/bufr/ufbpos.inc

   1       SUBROUTINE UFBPOS (LUNIT, IREC, ISUB, SUBSET, JDATE)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    UFBPOS
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1995-11-22
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
   9 !   LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS.  IT POSITIONS THE
  10 !   MESSAGE POINTER TO A USER-SPECIFIED BUFR MESSAGE NUMBER IN THE FILE
  11 !   CONNECTED TO LUNIT AND THEN CALLS BUFR ARCHIVE LIBRARY SUBROUTINE
  12 !   READMG TO READ THIS BUFR MESSAGE INTO A MESSAGE BUFFER (ARRAY MBAY
  13 !   IN COMMON BLOCK /BITBUF/).  IT THEN POSITIONS THE SUBSET POINTER TO
  14 !   A USER-SPECIFIED SUBSET NUMBER WITHIN THE BUFR MESSAGE AND CALLS
  15 !   BUFR ARCHIVE LIBRARY SUBROUTINE READSB TO READ THIS SUBSET INTO
  16 !   INTERNAL SUBSET ARRAYS.  THE BUFR MESSAGE HERE MAY BE EITHER
  17 !   COMPRESSED OR UNCOMPRESSED.  THE USER-SPECIFIED MESSAGE NUMBER DOES
  18 !   NOT INCLUDE  ANY DICTIONARY MESSAGES THAT MAY BE AT THE TOP OF THE
  19 !   FILE).
  20 !
  21 ! PROGRAM HISTORY LOG:
  22 ! 1995-11-22  J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN-LINED IN PROGRAM
  23 !                           NAM_STNMLIST)
  24 ! 2005-03-04  D. KEYSER  -- ADDED TO BUFR ARCHIVE LIBRARY; ADDED
  25 !                           DOCUMENTATION
  26 ! 2005-11-29  J. ATOR    -- USE IUPBS01 AND RDMSGW
  27 ! 2006-04-14  J. ATOR    -- REMOVE UNNECESSARY MOIN INITIALIZATION
  28 !
  29 ! USAGE:    CALL UFBPOS( LUNIT, IREC, ISUB, SUBSET, JDATE )
  30 !   INPUT ARGUMENT LIST:
  31 !     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  32 !     IREC     - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN
  33 !                FILE (DOES NOT INCLUDE  ANY DICTIONARY MESSSAGES THAT
  34 !                MAY BE AT THE TOP OF THE FILE)
  35 !     ISUB     - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR
  36 !                MESSAGE
  37 !
  38 !   OUTPUT ARGUMENT LIST:
  39 !     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
  40 !                BEING READ
  41 !     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
  42 !                MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR
  43 !                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
  44 !
  45 ! REMARKS:
  46 !    THIS ROUTINE CALLS:        BORT     IUPBS01  NMSUB    RDMSGW
  47 !                               READMG   READSB   STATUS   UFBCNT
  48 !                               UPB
  49 !    THIS ROUTINE IS CALLED BY: None
  50 !                               Normally called only by application
  51 !                               programs.
  52 !
  53 ! ATTRIBUTES:
  54 !   LANGUAGE: FORTRAN 77
  55 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  56 !
  57 !$$$
  58
  59       INCLUDE 'bufrlib.prm'
  60
  61       COMMON / MSGCWD / NMSG (NFILES), NSUB (NFILES), MSUB (NFILES),    &
  62       INODE (NFILES), IDATE (NFILES)
  63       COMMON / BITBUF / MAXBYT, IBIT, IBAY (MXMSGLD4), MBYT (NFILES),   &
  64       MBAY (MXMSGLD4, NFILES)
  65
  66       CHARACTER(128) BORT_STR
  67       CHARACTER(8) SUBSET
  68       DIMENSION MOIN (MXMSGLD4)
  69
  70 !-----------------------------------------------------------------------
  71 !----------------------------------------------------------------------
  72
  73 !  MAKE SURE A FILE IS OPEN FOR INPUT
  74 !  ----------------------------------
  75
  76       CALL STATUS (LUNIT, LUN, IL, IM)
  77       IF (IL.EQ.0) GOTO 900
  78       IF (IL.GT.0) GOTO 901
  79
  80       IF (IREC.LE.0) GOTO 902
  81       IF (ISUB.LE.0) GOTO 903
  82
  83 !  SEE WHERE POINTERS ARE CURRENTLY LOCATED
  84 !  ----------------------------------------
  85
  86       CALL UFBCNT (LUNIT, JREC, JSUB)
  87
  88 !  POSSIBLY REWIND AND POSITION AFTER THE DICTIONARY
  89 !   (IF REQUESTED POINTERS ARE BEHIND CURRENT POINTERS)
  90 !  ----------------------------------------------------
  91
  92       IF (IREC.LT.JREC.OR. (IREC.EQ.JREC.AND.ISUB.LT.JSUB) ) THEN
  93          IDEX = 0
  94          MSGT = 11
  95          REWIND LUNIT
  96          DO WHILE (MSGT.EQ.11)
  97          CALL RDMSGW (LUNIT, MOIN, IER)
  98          MSGT = IUPBS01 (MOIN, 'MTYP')
  99          IDEX = IDEX + 1
 100          ENDDO
 101          REWIND LUNIT
 102          DO NDX = 1, IDEX - 1
 103          CALL RDMSGW (LUNIT, MOIN, IER)
 104          ENDDO
 105          NMSG (LUN) = 0
 106          NSUB (LUN) = 0
 107          CALL UFBCNT (LUNIT, JREC, JSUB)
 108       ENDIF
 109
 110 !  READ SUBSET #ISUB FROM MESSAGE #IREC FROM FILE
 111 !  ----------------------------------------------
 112
 113       DO WHILE (IREC.GT.JREC)
 114       CALL READMG (LUNIT, SUBSET, JDATE, IRET)
 115       IF (IRET.NE.0) GOTO 904
 116       CALL UFBCNT (LUNIT, JREC, JSUB)
 117       ENDDO
 118
 119       KSUB = NMSUB (LUNIT)
 120       IF (ISUB.GT.KSUB) GOTO 905
 121
 122       DO WHILE (ISUB - 1.GT.JSUB)
 123       IBIT = MBYT (LUN) * 8
 124       CALL UPB (NBYT, 16, MBAY (1, LUN), IBIT)
 125       MBYT (LUN) = MBYT (LUN) + NBYT
 126       NSUB (LUN) = NSUB (LUN) + 1
 127       CALL UFBCNT (LUNIT, JREC, JSUB)
 128       ENDDO
 129
 130       CALL READSB (LUNIT, IRET)
 131       IF (IRET.NE.0) GOTO 905
 132
 133 !  EXITS
 134 !  -----
 135
 136       RETURN
 137   900 CALL BORT ('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST'/&
 138      &/' BE OPEN FOR INPUT')
 139   901 CALL BORT ('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT'/&
 140      &/', IT MUST BE OPEN FOR INPUT')
 141   902 WRITE (BORT_STR, '("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '//&
 142       'TO READ IN (",I5,") IS NOT VALID")') IREC
 143       CALL BORT (BORT_STR)
 144   903 WRITE (BORT_STR, '("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER '// &
 145       'TO READ IN (",I5,") IS NOT VALID")') ISUB
 146       CALL BORT (BORT_STR)
 147   904 WRITE (BORT_STR, '("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '//&
 148       'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE '//    &
 149       'FILE (",I5,")")') IREC, JREC
 150       CALL BORT (BORT_STR)
 151   905 WRITE (BORT_STR, '("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'/&
 152      &/' IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '//'R&
 153      &EQ. MESSAGE (",I5,")")') ISUB, KSUB, IREC
 154       CALL BORT (BORT_STR)
 155       END SUBROUTINE UFBPOS