var/external/bufr/rdtree.f

   1       SUBROUTINE RDTREE(LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDTREE
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL
   9 C   UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN COMMON BLOCK /BITBUF/)
  10 C   AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN)
  11 C   IN COMMON BLOCK /USRINT/.
  12 C
  13 C PROGRAM HISTORY LOG:
  14 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  15 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  16 C                           LINING CODE WITH FPP DIRECTIVES
  17 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  18 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  19 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  20 C                           BUFR FILES UNDER THE MPI)
  21 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  22 C                           10,000 TO 20,000 BYTES
  23 C 2003-11-04  J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN
  24 C                           THE LAST ELEMENT IN A SUBSET IS A CHARACTER
  25 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  26 C                           INTERDEPENDENCIES
  27 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  28 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  29 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  30 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  31 C                           HISTORY)
  32 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  33 C                           20,000 TO 50,000 BYTES
  34 C 2007-01-19  J. ATOR    -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
  35 C                           THAN 8 CHARACTERS
  36 C 2012-03-02  J. ATOR    -- USE FUNCTION UPS
  37 C 2012-06-04  J. ATOR    -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN
  38 C                           CORRESPONDING CHARACTER FIELD HAS ALL BITS
  39 C                           SET TO 1
  40 C
  41 C USAGE:    CALL RDTREE (LUN)
  42 C   INPUT ARGUMENT LIST:
  43 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  44 C
  45 C REMARKS:
  46 C    THIS ROUTINE CALLS:        RCSTPL   ICBFMS   UPBB     UPC
  47 C                               UPS
  48 C    THIS ROUTINE IS CALLED BY: READSB
  49 C                               Normally not called by any application
  50 C                               programs.
  51 C
  52 C ATTRIBUTES:
  53 C   LANGUAGE: FORTRAN 77
  54 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  55 C
  56 C$$$
  57
  58       INCLUDE 'bufrlib.prm'
  59
  60       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  61      .                MBAY(MXMSGLD4,NFILES)
  62       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  63      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  64      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  65      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  66      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  67       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  68       COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS)
  69
  70       CHARACTER*10 TAG
  71       CHARACTER*8  CVAL
  72       CHARACTER*3  TYP
  73       DIMENSION    IVAL(MAXSS)
  74       EQUIVALENCE  (CVAL,RVAL)
  75       REAL*8       VAL,RVAL,UPS
  76
  77 C-----------------------------------------------------------------------
  78 C     Statement function to compute BUFR "missing value" for field
  79 C     of length IBT(NODE)) bits (all bits "on"):
  80
  81       MPS(NODE) = 2**(IBT(NODE))-1
  82 C-----------------------------------------------------------------------
  83
  84 C  CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE
  85 C  ----------------------------------------------
  86
  87       MBIT(1) = IBIT
  88       NBIT(1) = 0
  89       CALL RCSTPL(LUN)
  90
  91 C  UNPACK A SUBSET INTO THE USER ARRAY IVAL
  92 C  ----------------------------------------
  93
  94       DO N=1,NVAL(LUN)
  95       CALL UPBB(IVAL(N),NBIT(N),MBIT(N),MBAY(1,LUN))
  96       ENDDO
  97
  98 C  LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED
  99 C  VALUES TO THE PROPER TYPES
 100 C  ----------------------------------------------------------------
 101
 102       DO N=1,NVAL(LUN)
 103       NODE = INV(N,LUN)
 104       IF(ITP(NODE).EQ.1) THEN
 105
 106 C        The unpacked value is a delayed descriptor replication factor.
 107
 108          VAL(N,LUN) = IVAL(N)
 109       ELSEIF(ITP(NODE).EQ.2) THEN
 110
 111 C        The unpacked value is a real.
 112
 113          IF(IVAL(N).LT.MPS(NODE)) VAL(N,LUN) = UPS(IVAL(N),NODE)
 114       ELSEIF(ITP(NODE).EQ.3) THEN
 115
 116 C        The value is a character string, so unpack it using an
 117 C        equivalenced REAL*8 value.  Note that a maximum of 8 characters
 118 C        will be unpacked here, so a separate subsequent call to BUFR
 119 C        archive library subroutine READLC will be needed to fully
 120 C        unpack any string longer than 8 characters.
 121
 122          CVAL = ' '
 123          KBIT = MBIT(N)
 124          NBT = MIN(8,NBIT(N)/8)
 125          CALL UPC(CVAL,NBT,MBAY(1,LUN),KBIT)
 126          IF (NBIT(N).LE.64 .AND. ICBFMS(CVAL,NBT).NE.0) THEN
 127             VAL(N,LUN) = BMISS
 128          ELSE
 129             VAL(N,LUN) = RVAL
 130          ENDIF
 131       ENDIF
 132       ENDDO
 133
 134       IBIT = NBIT(NVAL(LUN))+MBIT(NVAL(LUN))
 135
 136       RETURN
 137       END