var/external/bufr/rdcmps.f

   1       SUBROUTINE RDCMPS(LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDCMPS
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2000-09-19
   7 C
   8 C ABSTRACT: THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET
   9 C   FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON
  10 C   BLOCK /BITBUF/) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL
  11 C   ARRAY VAL(*,LUN) IN COMMON BLOCK /USRINT/.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 2000-09-19  J. WOOLLEN -- ORIGINAL AUTHOR
  15 C 2002-05-14  J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS
  16 C                           WOULD NOT RECOGNIZE COMPRESSED DELAYED
  17 C                           REPLICATION AS A LEGITIMATE DATA STRUCTURE
  18 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  19 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  20 C                           INTERDEPENDENCIES
  21 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  22 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  23 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  24 C                           WRF; ADDED HISTORY DOCUMENTATION
  25 C 2004-08-18  J. ATOR    -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC;
  26 C                           CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS
  27 C                           THE SAME FOR ALL SUBSETS IN A MESSAGE;
  28 C                           MAXIMUM MESSAGE LENGTH INCREASED FROM
  29 C                           20,000 TO 50,000 BYTES
  30 C 2009-03-23  J. ATOR    -- PREVENT OVERFLOW OF CVAL AND CREF FOR
  31 C                           STRINGS LONGER THAN 8 CHARACTERS
  32 C 2012-03-02  J. ATOR    -- USE FUNCTION UPS
  33 C 2012-06-04  J. ATOR    -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN
  34 C                           CORRESPONDING CHARACTER FIELD HAS ALL BITS
  35 C                           SET TO 1
  36 C
  37 C USAGE:    CALL RDCMPS (LUN)
  38 C   INPUT ARGUMENT LIST:
  39 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  40 C
  41 C REMARKS:
  42 C    THIS ROUTINE CALLS:        BORT     ICBFMS   UPB      UPC
  43 C                               UPS      USRTPL
  44 C    THIS ROUTINE IS CALLED BY: READSB
  45 C                               Normally not called by any application
  46 C                               programs.
  47 C
  48 C ATTRIBUTES:
  49 C   LANGUAGE: FORTRAN 77
  50 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  51 C
  52 C$$$
  53
  54       INCLUDE 'bufrlib.prm'
  55
  56       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  57      .                MBAY(MXMSGLD4,NFILES)
  58       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  59      .                INODE(NFILES),IDATE(NFILES)
  60       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  61      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  62      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  63      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  64      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  65       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  66       COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST)
  67
  68       CHARACTER*128 BORT_STR
  69       CHARACTER*10  TAG,CRTAG
  70       CHARACTER*8   CREF,CVAL
  71       CHARACTER*3   TYP
  72       EQUIVALENCE   (CVAL,RVAL)
  73       REAL*8        VAL,RVAL,UPS
  74
  75 C-----------------------------------------------------------------------
  76 C     Statement function to compute BUFR "missing value" for field
  77 C     of length LBIT bits (all bits "on"):
  78
  79       LPS(LBIT) = MAX(2**(LBIT)-1,1)
  80 C-----------------------------------------------------------------------
  81
  82 C  SETUP THE SUBSET TEMPLATE
  83 C  -------------------------
  84
  85       CALL USRTPL(LUN,1,1)
  86
  87 C  UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B
  88 C  -----------------------------------------------------------
  89
  90       NSBS = NSUB(LUN)
  91
  92 C     Note that we are going to unpack the (NSBS)th subset from within
  93 C     the current BUFR message.
  94
  95       IBIT = MBYT(LUN)
  96       NRST = 0
  97
  98 C     Loop through each element of the subset.
  99
 100       N = 0
 101
 102 1     DO N=N+1,NVAL(LUN)
 103       NODE = INV(N,LUN)
 104       NBIT = IBT(NODE)
 105       ITYP = ITP(NODE)
 106
 107 C     In each of the following code blocks, the "local reference value"
 108 C     for the element is determined first, followed by the 6-bit value
 109 C     which indicates how many bits are used to store the increment
 110 C     (i.e. offset) from this "local reference value".  Then, we jump
 111 C     ahead to where this increment is stored for this particular subset,
 112 C     unpack it, and add it to the "local reference value" to determine
 113 C     the final uncompressed value for this element from this subset.
 114
 115 C     Note that, if an element has the same final uncompressed value
 116 C     for each subset in the message, then the encoding rules for BUFR
 117 C     compression dictate that the "local reference value" will be equal
 118 C     to this value, the 6-bit increment length indicator will have
 119 C     a value of zero, and the actual increments themselves will be
 120 C     omitted from the message.
 121
 122       IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN
 123
 124 C        This is a numeric element.
 125
 126          CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT)
 127          CALL UPB(LINC,   6,MBAY(1,LUN),IBIT)
 128          JBIT = IBIT + LINC*(NSBS-1)
 129          CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT)
 130          IF(NINC.EQ.LPS(LINC)) THEN
 131             IVAL = LPS(NBIT)
 132          ELSE
 133             IVAL = LREF+NINC
 134          ENDIF
 135          IF(ITYP.EQ.1) THEN
 136             CALL USRTPL(LUN,N,IVAL)
 137             GOTO 1
 138          ENDIF
 139          IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE)
 140          IBIT = IBIT + LINC*MSUB(LUN)
 141       ELSEIF(ITYP.EQ.3) THEN
 142
 143 C        This is a character element.  If there are more than 8
 144 C        characters, then only the first 8 will be unpacked by this
 145 C        routine, and a separate subsequent call to BUFR archive library
 146 C        subroutine READLC will be required to unpack the remainder of
 147 C        the string.  In this case, pointers will be saved within
 148 C        COMMON /RLCCMN/ for later use within READLC.
 149
 150 C        Unpack the local reference value.
 151
 152          LELM = NBIT/8
 153          NCHR = MIN(8,LELM)
 154          IBSV = IBIT
 155          CREF = ' '
 156          CALL UPC(CREF,NCHR,MBAY(1,LUN),IBIT)
 157          IF(LELM.GT.8) THEN
 158             IBIT = IBIT + (LELM-8)*8
 159             NRST = NRST + 1
 160             IF(NRST.GT.MXRST) GOTO 900
 161             CRTAG(NRST) = TAG(NODE)
 162          ENDIF
 163
 164 C        Unpack the increment length indicator.  For character elements,
 165 C        this length is in bytes rather than bits.
 166
 167          CALL UPB(LINC,   6,MBAY(1,LUN),IBIT)
 168          IF(LINC.EQ.0) THEN
 169             IF(LELM.GT.8) THEN
 170                IRNCH(NRST) = LELM
 171                IRBIT(NRST) = IBSV
 172             ENDIF
 173             CVAL = CREF
 174          ELSE
 175             JBIT = IBIT + LINC*(NSBS-1)*8
 176             IF(LELM.GT.8) THEN
 177                IRNCH(NRST) = LINC
 178                IRBIT(NRST) = JBIT
 179             ENDIF
 180             NCHR = MIN(8,LINC)
 181             CVAL = ' '
 182             CALL UPC(CVAL,NCHR,MBAY(1,LUN),JBIT)
 183          ENDIF
 184          IF (LELM.LE.8 .AND. ICBFMS(CVAL,NCHR).NE.0) THEN
 185             VAL(N,LUN) = BMISS
 186          ELSE
 187             VAL(N,LUN) = RVAL
 188          ENDIF
 189          IBIT = IBIT + 8*LINC*MSUB(LUN)
 190       ENDIF
 191       ENDDO
 192
 193       RETURN
 194 900   WRITE(BORT_STR,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' //
 195      .   'STRINGS EXCEEDS THE LIMIT (",I4,")")') MXRST
 196       CALL BORT(BORT_STR)
 197       END