ufbpos.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1995-11-22
      
C> THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
C>   LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS.  IT POSITIONS THE
C>   MESSAGE POINTER TO A USER-SPECIFIED BUFR MESSAGE NUMBER IN THE FILE
C>   CONNECTED TO LUNIT AND THEN CALLS BUFR ARCHIVE LIBRARY SUBROUTINE
C>   READMG TO READ THIS BUFR MESSAGE INTO A MESSAGE BUFFER (ARRAY MBAY
C>   IN MODULE BITBUF).  IT THEN POSITIONS THE SUBSET POINTER TO
C>   A USER-SPECIFIED SUBSET NUMBER WITHIN THE BUFR MESSAGE AND CALLS
C>   BUFR ARCHIVE LIBRARY SUBROUTINE READSB TO READ THIS SUBSET INTO
C>   INTERNAL SUBSET ARRAYS.  THE BUFR MESSAGE HERE MAY BE EITHER
C>   COMPRESSED OR UNCOMPRESSED.  THE USER-SPECIFIED MESSAGE NUMBER DOES
C>   NOT INCLUDE ANY DICTIONARY MESSAGES THAT MAY BE AT THE TOP OF THE
C>   FILE).
C>
C> PROGRAM HISTORY LOG:
C> 1995-11-22  J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN-LINED IN PROGRAM
C>                           NAM_STNMLIST)
C> 2005-03-04  D. KEYSER  -- ADDED TO BUFR ARCHIVE LIBRARY; ADDED
C>                           DOCUMENTATION
C> 2005-11-29  J. ATOR    -- USE IUPBS01 AND RDMSGW
C> 2006-04-14  J. ATOR    -- REMOVE UNNECESSARY MOIN INITIALIZATION
C> 2009-03-23  J. ATOR    -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE
C>                           (DICTIONARY) MESSAGES
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL UFBPOS( LUNIT, IREC, ISUB, SUBSET, JDATE )
C>   INPUT ARGUMENT LIST:
C>     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C>     IREC     - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN
C>                FILE (DOES NOT INCLUDE ANY DICTIONARY MESSSAGES THAT
C>                MAY BE AT THE TOP OF THE FILE)
C>     ISUB     - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR
C>                MESSAGE
C>
C>   OUTPUT ARGUMENT LIST:
C>     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
C>                BEING READ
C>     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
C>                MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR
C>                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     CEWIND   NMSUB    READMG
C>                               READSB   STATUS   UFBCNT   UPB
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE ufbpos(LUNIT,IREC,ISUB,SUBSET,JDATE)

      USE moda_msgcwd
      USE moda_bitbuf

      CHARACTER*128 bort_str
      CHARACTER*8   subset
 
C-----------------------------------------------------------------------
C----------------------------------------------------------------------

C  MAKE SURE A FILE IS OPEN FOR INPUT
C  ----------------------------------

      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) goto 900
      IF(il.GT.0) goto 901

      IF(irec.LE.0)  goto 902
      IF(isub.LE.0)  goto 903

C  SEE WHERE POINTERS ARE CURRENTLY LOCATED
C  ----------------------------------------

      CALL ufbcnt(lunit,jrec,jsub)
 
C  REWIND FILE IF REQUESTED POINTERS ARE BEHIND CURRENT POINTERS
C  -------------------------------------------------------------
 
      IF(irec.LT.jrec .OR. (irec.EQ.jrec.AND.isub.LT.jsub)) THEN
         CALL cewind(lun)
         nmsg(lun) = 0
         nsub(lun) = 0
         CALL ufbcnt(lunit,jrec,jsub)
      ENDIF

C  READ SUBSET #ISUB FROM MESSAGE #IREC FROM FILE
C  ----------------------------------------------

      DO WHILE (irec.GT.jrec)
         CALL readmg(lunit,subset,jdate,iret)
         IF(iret.LT.0) goto 904
         CALL ufbcnt(lunit,jrec,jsub)
      ENDDO

      ksub = nmsub(lunit)
      IF(isub.GT.ksub)  goto 905

      DO WHILE (isub-1.GT.jsub)
         ibit = mbyt(lun)*8
         CALL upb(nbyt,16,mbay(1,lun),ibit)
         mbyt(lun) = mbyt(lun) + nbyt
         nsub(lun) = nsub(lun) + 1
         CALL ufbcnt(lunit,jrec,jsub)
      ENDDO

      CALL readsb(lunit,iret)
      IF(iret.NE.0) goto 905

C  EXITS
C  -----

      RETURN
900   CALL bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   WRITE(bort_str,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '//
     . 'TO READ IN (",I5,") IS NOT VALID")') irec
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER '//
     . 'TO READ IN (",I5,") IS NOT VALID")') isub
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '//
     . 'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE '//
     . 'FILE (",I5,")")') irec,jrec
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'//
     . ' IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '//
     . 'REQ. MESSAGE (",I5,")")') isub,ksub,irec
      CALL bort(bort_str)
      END