ufbget.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE UNPACKS AND RETURNS THE VALUES FOR ONE-
C>   DIMENSIONAL DESCRIPTORS IN THE INPUT STRING WITHOUT ADVANCING THE
C>   SUBSET POINTER.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; IMPROVED MACHINE
C>                           PORTABILITY
C> 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C>                           LINING CODE WITH FPP DIRECTIVES
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           10,000 TO 20,000 BYTES
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C>                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
C> 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2012-03-02  J. ATOR    -- USE FUNCTION UPS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL UFBGET (LUNIT, TAB, I1, IRET, STR)
C>   INPUT ARGUMENT LIST:
C>     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C>     I1       - INTEGER: LENGTH OF TAB
C>     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
C>                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH THE WORDS
C>                IN THE ARRAY TAB
C>                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
C>                     TO TABLE B, THESE RETURN THE FOLLOWING
C>                     INFORMATION IN CORRESPONDING TAB LOCATION:
C>                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
C>                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
C>                            MESSAGE (RECORD) NUMBER IN WHICH THIS
C>                            SUBSET RESIDES
C>                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
C>                            NUMBER OF THIS SUBSET WITHIN THE BUFR
C>                            MESSAGE (RECORD) NUMBER 'IREC'
C>
C>   OUTPUT ARGUMENT LIST:
C>     TAB      - REAL*8: (I1) STARTING ADDRESS OF DATA VALUES READ FROM
C>                DATA SUBSET
C>     IRET     - INTEGER: RETURN CODE:
C>                       0 = normal return
C>                      -1 = there are no more subsets in the BUFR
C>                           message
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     INVWIN   STATUS   STRING
C>                               UPBB     UPC      UPS      USRTPL
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE ufbget(LUNIT,TAB,I1,IRET,STR)

      USE modv_bmiss
      USE moda_usrint
      USE moda_usrbit
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables

      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)

      CHARACTER*(*) str
      CHARACTER*8   cval
      equivalence(cval,rval)
      REAL*8        rval,tab(i1),ups

C-----------------------------------------------------------------------
      mps(node) = 2**(ibt(node))-1
C-----------------------------------------------------------------------

      iret = 0

      DO i=1,i1
      tab(i) = bmiss
      ENDDO

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

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

C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
C  ---------------------------------------------

      IF(nsub(lun).EQ.msub(lun)) THEN
         iret = -1
         goto 100
      ENDIF

C  PARSE THE STRING
C  ----------------

      CALL string(str,lun,i1,0)

C  EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE
C  ---------------------------------------------------------

      n = 1
      nbit(n) = 0
      mbit(n) = mbyt(lun)*8 + 16
      CALL usrtpl(lun,n,n)

10    DO n=n+1,nval(lun)
      node = inv(n,lun)
      nbit(n) = ibt(node)
      mbit(n) = mbit(n-1)+nbit(n-1)
      IF(node.EQ.nods(nnod)) THEN
         nval(lun) = n
         goto 20
      ELSEIF(itp(node).EQ.1) THEN
         CALL upbb(ival,nbit(n),mbit(n),mbay(1,lun))
         CALL usrtpl(lun,n,ival)
         goto 10
      ENDIF
      ENDDO
20    CONTINUE

C  UNPACK ONLY THE NODES FOUND IN THE STRING
C  -----------------------------------------

      DO i=1,nnod
      node = nods(i)
      invn = invwin(node,lun,1,nval(lun))
      IF(invn.GT.0) THEN
         CALL upbb(ival,nbit(invn),mbit(invn),mbay(1,lun))
         IF(itp(node).EQ.1) THEN
            tab(i) = ival
         ELSEIF(itp(node).EQ.2) THEN
            IF(ival.LT.mps(node)) tab(i) = ups(ival,node)
         ELSEIF(itp(node).EQ.3) THEN
            cval = ' '
            kbit = mbit(invn)
            CALL upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
            tab(i) = rval
         ENDIF
      ELSE
         tab(i) = bmiss
      ENDIF
      ENDDO

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
      END