ups.f

Go to the documentation of this file.

C> @file
C> @author J @date 2012-03-02
    
C> THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED
C>   BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES.
C>   NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX
C>   NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*);
C>   HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A
C>   2-03 OPERATOR IS IN EFFECT FOR THIS NODE.
C>
C> PROGRAM HISTORY LOG:
C> 2012-03-02  J. ATOR    -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL
C>                           STATEMENT FUNCTION IN OTHER SUBROUTINES
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2022-05-06  J. WOOLLEN -- MAKE IVAL AND IMASK 8BYTE INTEGERS  
C>
C> USAGE:    UPS (IVAL,NODE)
C>   INPUT ARGUMENT LIST:
C>     IVAL      - INTEGER: PACKED BUFR INTEGER
C>     NODE      - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES
C>
C>   OUTPUT ARGUMENT LIST:
C>     UPS       - REAL*8: USER VALUE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        None
C>    THIS ROUTINE IS CALLED BY: RDCMPS   RDTREE   UFBGET   UFBTAB
C>                               UFBTAM
C>                               Normally not called by any application
C>                               programs.
C>
    REAL*8 FUNCTION ups(IVAL,NODE)
 
    USE moda_tables
    USE moda_nrv203
 
        integer*8 ival,imask
    real*8    ten
 
    DATA ten /10./
 
C-----------------------------------------------------------------------
 
    ups = ( ival + irf(node) ) * ten**(-isc(node))
 
    IF ( nnrv .GT. 0 ) THEN
 
C     There are redefined reference values in the jump/link table,
C     so we need to check if this node is affected by any of them.
 
      DO jj = 1, nnrv
        IF ( node .EQ. inodnrv(jj) ) THEN
 
C         This node contains a redefined reference value.
C         Per the rules of BUFR, negative values may be encoded
C         as positive integers with the left-most bit set to 1.
 
          imask = 2_8**(ibt(node)-1)
          IF ( iand(ival,imask) .GT. 0 ) THEN
        nrv(jj) = (-1) * ( ival - imask )
          ELSE
        nrv(jj) = ival
          END IF
          ups = nrv(jj)
          RETURN
        ELSE IF ( ( tag(node)(1:8) .EQ. tagnrv(jj) ) .AND.      
     .            ( node .GE. isnrv(jj) ) .AND.
     .            ( node .LE. ienrv(jj) ) ) THEN
 
C         The corresponding redefinded reference value needs to
C         be used when decoding this value.
 
          ups = ( ival + nrv(jj) ) * ten**(-isc(node))
          RETURN
        END IF
      END DO
 
    END IF
 
    RETURN
    END