ipks.f

Go to the documentation of this file.

C> @file
C> @author J @date 2012-03-02
    
C> THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR
C>   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 WRTREE
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2022-05-06  J. WOOLLEN -- MAKE IMASK AND IPKS 8BYTE INTEGERS  
C>
C> USAGE:    IPKS (VAL,NODE)
C>   INPUT ARGUMENT LIST:
C>     VAL       - REAL*8: USER VALUE
C>     NODE      - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES
C>
C>   OUTPUT ARGUMENT LIST:
C>     IPKS      - INTEGER*8: PACKED BUFR VALUE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        None
C>    THIS ROUTINE IS CALLED BY: WRTREE
C>                               Normally not called by any application
C>                               programs.
C>
    FUNCTION ipks(VAL,NODE)
 
    USE moda_tables
    USE moda_nrv203
 
        integer(8) imask, ipks
    real*8     ten,val
 
    DATA ten /10./
 
C-----------------------------------------------------------------------
 
    ipks = val * ten**isc(node) - irf(node) + .5
 
    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 should be encoded
C         as positive integers with the left-most bit set to 1.
 
          nrv(jj) = nint(val)
          IF ( nrv(jj) .LT. 0 ) THEN
        imask = 2_8**(ibt(node)-1)
        ipks = ior(abs(nrv(jj)),imask)
          ELSE
        ipks = nrv(jj)
          END IF
          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 encoding this value.
 
          ipks = val * ten**isc(node) - nrv(jj) + .5
          RETURN
        END IF
      END DO
 
    END IF
 
    RETURN
    END