var/external/bufr/wrtree.f

   1       SUBROUTINE WRTREE(LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    WRTREE
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS
   9 C   AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER.
  10 C
  11 C PROGRAM HISTORY LOG:
  12 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  13 C 1998-07-08  J. WOOLLEN -- CORRECTED SOME MINOR ERRORS
  14 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  15 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  16 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  17 C                           BUFR FILES UNDER THE MPI)
  18 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  19 C                           10,000 TO 20,000 BYTES
  20 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  21 C                           INTERDEPENDENCIES
  22 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  23 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  24 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  25 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  26 C                           HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))"
  27 C                           WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER
  28 C                           CAUSED PROBLEMS ON SOME FOREIGN MACHINES)
  29 C 2004-03-10  J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8
  30 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  31 C                           20,000 TO 50,000 BYTES
  32 C 2007-01-19  J. ATOR    -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
  33 C                           THAN 8 CHARACTERS; USE FUNCTION IBFMS
  34 C 2009-08-03  J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA
  35 C                           UFBCPY USING FILE POINTER STORED IN NEW
  36 C                           COMMON UFBCPL
  37 C 2012-03-02  J. ATOR    -- USE IPKS TO HANDLE 2-03 OPERATOR CASES
  38 C 2012-06-04  J. ATOR    -- ENSURE "MISSING" CHARACTER FIELDS ARE
  39 C                           PROPERLY ENCODED WITH ALL BITS SET TO 1
  40 C
  41 C USAGE:    CALL WRTREE (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:        IBFMS    IPKM     PKB      PKC
  47 C                               IPKS     READLC
  48 C    THIS ROUTINE IS CALLED BY: WRITSA   WRITSB
  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 /UFBCPL/ LUNCPY(NFILES)
  69
  70       CHARACTER*120 LSTR
  71       CHARACTER*10  TAG
  72       CHARACTER*8   CVAL
  73       CHARACTER*3   TYP
  74       DIMENSION     IVAL(MAXSS)
  75       EQUIVALENCE   (CVAL,RVAL)
  76       REAL*8        VAL,RVAL
  77
  78 C-----------------------------------------------------------------------
  79
  80 C  CONVERT USER NUMBERS INTO SCALED INTEGERS
  81 C  -----------------------------------------
  82
  83       DO N=1,NVAL(LUN)
  84       NODE = INV(N,LUN)
  85       IF(ITP(NODE).EQ.1) THEN
  86          IVAL(N) = VAL(N,LUN)
  87       ELSEIF(TYP(NODE).EQ.'NUM') THEN
  88          IF(IBFMS(VAL(N,LUN)).EQ.0) THEN
  89             IVAL(N) = IPKS(VAL(N,LUN),NODE)
  90          ELSE
  91             IVAL(N) = -1
  92          ENDIF
  93       ENDIF
  94       ENDDO
  95
  96 C  PACK THE USER ARRAY INTO THE SUBSET BUFFER
  97 C  ------------------------------------------
  98
  99       IBIT = 16
 100
 101       DO N=1,NVAL(LUN)
 102       NODE = INV(N,LUN)
 103       IF(ITP(NODE).LT.3) THEN
 104
 105 C        The value to be packed is numeric.
 106
 107          CALL PKB(IVAL(N),IBT(NODE),IBAY,IBIT)
 108       ELSE
 109
 110 C        The value to be packed is a character string.
 111
 112          NCR=IBT(NODE)/8
 113          IF ( NCR.GT.8 .AND. LUNCPY(LUN).NE.0 ) THEN
 114
 115 C           The string is longer than 8 characters and there was a
 116 C           preceeding call to UFBCPY involving this output unit, so
 117 C           read the long string with READLC and write it into the
 118 C           output buffer using PKC.
 119
 120             CALL READLC(LUNCPY(LUN),LSTR,TAG(NODE))
 121             CALL PKC(LSTR,NCR,IBAY,IBIT)
 122          ELSE
 123             RVAL = VAL(N,LUN)
 124             IF(IBFMS(RVAL).NE.0) THEN
 125
 126 C              The value is "missing", so set all bits to 1 before
 127 C              packing the field as a character string.
 128
 129                NUMCHR = MIN(NCR,LEN(LSTR))
 130                DO JJ = 1, NUMCHR
 131                   CALL IPKM(LSTR(JJ:JJ),1,255)
 132                ENDDO
 133                CALL PKC(LSTR,NUMCHR,IBAY,IBIT)
 134             ELSE
 135
 136 C              The value is not "missing", so pack the equivalenced
 137 C              character string.  Note that a maximum of 8 characters
 138 C              will be packed here, so a separate subsequent call to
 139 C              BUFR archive library subroutine WRITLC will be needed to
 140 C              fully encode any string longer than 8 characters.
 141
 142                CALL PKC(CVAL,NCR,IBAY,IBIT)
 143             ENDIF
 144          ENDIF
 145
 146       ENDIF
 147       ENDDO
 148
 149 C  RESET UFBCPY FILE POINTER
 150 C  -------------------------
 151
 152       LUNCPY(LUN)=0
 153
 154       RETURN
 155       END