var/external/bufr/ipks.f

   1         INTEGER FUNCTION IPKS(VAL,NODE)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:   IPKS
   6 C   PRGMMR: J. ATOR          ORG: NP12       DATE: 2012-03-02
   7 C
   8 C ABSTRACT: THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR
   9 C   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 WRTREE
  18 C
  19 C USAGE:    IPKS (VAL,NODE)
  20 C   INPUT ARGUMENT LIST:
  21 C     VAL       - REAL*8: USER VALUE
  22 C     NODE      - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES
  23 C
  24 C   OUTPUT ARGUMENT LIST:
  25 C     IPKS      - INTEGER: PACKED BUFR VALUE
  26 C
  27 C REMARKS:
  28 C    THIS ROUTINE CALLS:        None
  29 C    THIS ROUTINE IS CALLED BY: WRTREE
  30 C                               Normally not called by any application
  31 C                               programs.
  32 C
  33 C ATTRIBUTES:
  34 C   LANGUAGE: FORTRAN 77
  35 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  36 C
  37 C$$$
  38
  39         INCLUDE 'bufrlib.prm'
  40
  41         COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  42      .                  JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  43      .                  IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  44      .                  ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  45      .                  ISEQ(MAXJL,2),JSEQ(MAXJL)
  46         COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
  47      .                  ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
  48
  49         CHARACTER*10  TAG
  50         CHARACTER*8   TAGNRV
  51         CHARACTER*3   TYP
  52
  53         REAL*8  TEN,VAL
  54
  55         DATA TEN /10./
  56
  57 C-----------------------------------------------------------------------
  58
  59         IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - IRF(NODE)
  60
  61         IF ( NNRV .GT. 0 ) THEN
  62
  63 C         There are redefined reference values in the jump/link table,
  64 C         so we need to check if this node is affected by any of them.
  65
  66           DO JJ = 1, NNRV
  67             IF ( NODE .EQ. INODNRV(JJ) ) THEN
  68
  69 C             This node contains a redefined reference value.
  70 C             Per the rules of BUFR, negative values should be encoded
  71 C             as positive integers with the left-most bit set to 1.
  72
  73               NRV(JJ) = NINT(VAL)
  74               IF ( NRV(JJ) .LT. 0 ) THEN
  75                 IMASK = 2**(IBT(NODE)-1)
  76                 IPKS = IOR(IABS(NRV(JJ)),IMASK)
  77               ELSE
  78                 IPKS = NRV(JJ)
  79               END IF
  80               RETURN
  81             ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND.
  82      .                ( NODE .GE. ISNRV(JJ) ) .AND.
  83      .                ( NODE .LE. IENRV(JJ) ) ) THEN
  84
  85 C             The corresponding redefinded reference value needs to
  86 C             be used when encoding this value.
  87
  88               IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - NRV(JJ)
  89               RETURN
  90             END IF
  91           END DO
  92
  93         END IF
  94
  95         RETURN
  96         END