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>
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: 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>
    INTEGER FUNCTION ipks(VAL,NODE)

    USE moda_tables
    USE moda_nrv203

    real*8  ten,val

    DATA ten /10./

C-----------------------------------------------------------------------

    ipks = nint( val * ten**(isc(node)) ) - irf(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 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**(ibt(node)-1)
        ipks = ior(iabs(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 = nint( val * ten**(isc(node)) ) - nrv(jj)
          RETURN
        END IF
      END DO

    END IF

    RETURN
    END