SUBROUTINE RDCMPS(LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDCMPS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 C C ABSTRACT: THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET C FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON C BLOCK /BITBUF/) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL C ARRAY VAL(*,LUN) IN COMMON BLOCK /USRINT/. C C PROGRAM HISTORY LOG: C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS C WOULD NOT RECOGNIZE COMPRESSED DELAYED C REPLICATION AS A LEGITIMATE DATA STRUCTURE C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION C 2004-08-18 J. ATOR -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC; C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS C THE SAME FOR ALL SUBSETS IN A MESSAGE; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- PREVENT OVERFLOW OF CVAL AND CREF FOR C STRINGS LONGER THAN 8 CHARACTERS C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN C CORRESPONDING CHARACTER FIELD HAS ALL BITS C SET TO 1 C C USAGE: CALL RDCMPS (LUN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: BORT ICBFMS UPB UPC C UPS USRTPL C THIS ROUTINE IS CALLED BY: READSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), . MBAY(MXMSGLD4,NFILES) COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), . INODE(NFILES),IDATE(NFILES) COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), . ISEQ(MAXJL,2),JSEQ(MAXJL) COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST) CHARACTER*128 BORT_STR CHARACTER*10 TAG,CRTAG CHARACTER*8 CREF,CVAL CHARACTER*3 TYP EQUIVALENCE (CVAL,RVAL) REAL*8 VAL,RVAL,UPS C----------------------------------------------------------------------- C Statement function to compute BUFR "missing value" for field C of length LBIT bits (all bits "on"): LPS(LBIT) = MAX(2**(LBIT)-1,1) C----------------------------------------------------------------------- C SETUP THE SUBSET TEMPLATE C ------------------------- CALL USRTPL(LUN,1,1) C UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B C ----------------------------------------------------------- NSBS = NSUB(LUN) C Note that we are going to unpack the (NSBS)th subset from within C the current BUFR message. IBIT = MBYT(LUN) NRST = 0 C Loop through each element of the subset. N = 0 1 DO N=N+1,NVAL(LUN) NODE = INV(N,LUN) NBIT = IBT(NODE) ITYP = ITP(NODE) C In each of the following code blocks, the "local reference value" C for the element is determined first, followed by the 6-bit value C which indicates how many bits are used to store the increment C (i.e. offset) from this "local reference value". Then, we jump C ahead to where this increment is stored for this particular subset, C unpack it, and add it to the "local reference value" to determine C the final uncompressed value for this element from this subset. C Note that, if an element has the same final uncompressed value C for each subset in the message, then the encoding rules for BUFR C compression dictate that the "local reference value" will be equal C to this value, the 6-bit increment length indicator will have C a value of zero, and the actual increments themselves will be C omitted from the message. IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN C This is a numeric element. CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) JBIT = IBIT + LINC*(NSBS-1) CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) IF(NINC.EQ.LPS(LINC)) THEN IVAL = LPS(NBIT) ELSE IVAL = LREF+NINC ENDIF IF(ITYP.EQ.1) THEN CALL USRTPL(LUN,N,IVAL) GOTO 1 ENDIF IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE) IBIT = IBIT + LINC*MSUB(LUN) ELSEIF(ITYP.EQ.3) THEN C This is a character element. If there are more than 8 C characters, then only the first 8 will be unpacked by this C routine, and a separate subsequent call to BUFR archive library C subroutine READLC will be required to unpack the remainder of C the string. In this case, pointers will be saved within C COMMON /RLCCMN/ for later use within READLC. C Unpack the local reference value. LELM = NBIT/8 NCHR = MIN(8,LELM) IBSV = IBIT CREF = ' ' CALL UPC(CREF,NCHR,MBAY(1,LUN),IBIT) IF(LELM.GT.8) THEN IBIT = IBIT + (LELM-8)*8 NRST = NRST + 1 IF(NRST.GT.MXRST) GOTO 900 CRTAG(NRST) = TAG(NODE) ENDIF C Unpack the increment length indicator. For character elements, C this length is in bytes rather than bits. CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) IF(LINC.EQ.0) THEN IF(LELM.GT.8) THEN IRNCH(NRST) = LELM IRBIT(NRST) = IBSV ENDIF CVAL = CREF ELSE JBIT = IBIT + LINC*(NSBS-1)*8 IF(LELM.GT.8) THEN IRNCH(NRST) = LINC IRBIT(NRST) = JBIT ENDIF NCHR = MIN(8,LINC) CVAL = ' ' CALL UPC(CVAL,NCHR,MBAY(1,LUN),JBIT) ENDIF IF (LELM.LE.8 .AND. ICBFMS(CVAL,NCHR).NE.0) THEN VAL(N,LUN) = BMISS ELSE VAL(N,LUN) = RVAL ENDIF IBIT = IBIT + 8*LINC*MSUB(LUN) ENDIF ENDDO RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' // . 'STRINGS EXCEEDS THE LIMIT (",I4,")")') MXRST CALL BORT(BORT_STR) END