var/external/bufr/ups.f

   1         REAL*8 FUNCTION UPS(IVAL,NODE)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UPS
   6 C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2012-03-02
   7 C
   8 C ABSTRACT: THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED
   9 C   BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES.
  10 C   NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX
  11 C   NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*);
  12 C   HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A
  13 C   2-03 OPERATOR IS IN EFFECT FOR THIS NODE.
  14 C
  15 C PROGRAM HISTORY LOG:
  16 C 2012-03-02  J. ATOR    -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL
  17 C                           STATEMENT FUNCTION IN OTHER SUBROUTINES
  18 C
  19 C USAGE:    UPS (IVAL,NODE)
  20 C   INPUT ARGUMENT LIST:
  21 C     IVAL      - INTEGER: PACKED BUFR INTEGER
  22 C     NODE      - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES
  23 C
  24 C   OUTPUT ARGUMENT LIST:
  25 C     UPS       - REAL*8: USER VALUE
  26 C
  27 C REMARKS:
  28 C    THIS ROUTINE CALLS:        None
  29 C    THIS ROUTINE IS CALLED BY: RDCMPS   RDTREE   UFBGET   UFBTAB
  30 C                               UFBTAM
  31 C                               Normally not called by any application
  32 C                               programs.
  33 C
  34 C ATTRIBUTES:
  35 C   LANGUAGE: FORTRAN 77
  36 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  37 C
  38 C$$$
  39
  40         INCLUDE 'bufrlib.prm'
  41
  42         COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  43      .                  JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  44      .                  IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  45      .                  ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  46      .                  ISEQ(MAXJL,2),JSEQ(MAXJL)
  47         COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
  48      .                  ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
  49
  50         CHARACTER*10  TAG
  51         CHARACTER*8   TAGNRV
  52         CHARACTER*3   TYP
  53
  54         REAL*8  TEN
  55
  56         DATA TEN /10./
  57
  58 C-----------------------------------------------------------------------
  59
  60         UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE))
  61
  62         IF ( NNRV .GT. 0 ) THEN
  63
  64 C         There are redefined reference values in the jump/link table,
  65 C         so we need to check if this node is affected by any of them.
  66
  67           DO JJ = 1, NNRV
  68             IF ( NODE .EQ. INODNRV(JJ) ) THEN
  69
  70 C             This node contains a redefined reference value.
  71 C             Per the rules of BUFR, negative values may be encoded
  72 C             as positive integers with the left-most bit set to 1.
  73
  74               IMASK = 2**(IBT(NODE)-1)
  75               IF ( IAND(IVAL,IMASK) .GT. 0 ) THEN
  76                 NRV(JJ) = (-1) * ( IVAL - IMASK )
  77               ELSE
  78                 NRV(JJ) = IVAL
  79               END IF
  80               UPS = NRV(JJ)
  81               RETURN
  82             ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND.
  83      .                ( NODE .GE. ISNRV(JJ) ) .AND.
  84      .                ( NODE .LE. IENRV(JJ) ) ) THEN
  85
  86 C             The corresponding redefinded reference value needs to
  87 C             be used when decoding this value.
  88
  89               UPS = ( IVAL + NRV(JJ) ) * TEN**(-ISC(NODE))
  90               RETURN
  91             END IF
  92           END DO
  93
  94         END IF
  95
  96         RETURN
  97         END