wrfv2_fire/var/external/bufr/wrtree.inc

   1       SUBROUTINE WRTREE(LUN)
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    WRTREE
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS
   9 !   AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER.
  10 !
  11 ! PROGRAM HISTORY LOG:
  12 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  13 ! 1998-07-08  J. WOOLLEN -- CORRECTED SOME MINOR ERRORS
  14 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  15 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  16 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  17 !                           BUFR FILES UNDER THE MPI)
  18 ! 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  19 !                           10,000 TO 20,000 BYTES
  20 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  21 !                           INTERDEPENDENCIES
  22 ! 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  23 !                           INCREASED FROM 15000 TO 16000 (WAS IN
  24 !                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  25 !                           WRF; ADDED DOCUMENTATION (INCLUDING
  26 !                           HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))"
  27 !                           WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER
  28 !                           CAUSED PROBLEMS ON SOME FOREIGN MACHINES)
  29 ! 2004-03-10  J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8
  30 ! 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  31 !                           20,000 TO 50,000 BYTES
  32 ! 2007-01-19  J. ATOR    -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
  33 !                           THAN 8 CHARACTERS; USE FUNCTION IBFMS
  34 !
  35 ! USAGE:    CALL WRTREE (LUN)
  36 !   INPUT ARGUMENT LIST:
  37 !     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  38 !
  39 ! REMARKS:
  40 !    THIS ROUTINE CALLS:        IBFMS    PKB      PKC
  41 !    THIS ROUTINE IS CALLED BY: WRITSA   WRITSB
  42 !                               Normally not called by any application
  43 !                               programs.
  44 !
  45 ! ATTRIBUTES:
  46 !   LANGUAGE: FORTRAN 77
  47 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  48 !
  49 !$$$
  50
  51       INCLUDE 'bufrlib.prm'
  52
  53       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), &
  54                       MBAY(MXMSGLD4,NFILES)
  55 !     COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), &
  56 !                     JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), &
  57 !                     IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), &
  58 !                     ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), &
  59 !                     ISEQ(MAXJL,2),JSEQ(MAXJL)
  60 !     COMMON /USRINT/ NVAL(NFILES),INV(MAXJL,NFILES),VAL(MAXJL,NFILES)
  61
  62 !     CHARACTER*10 TAG
  63       CHARACTER*8  CVAL
  64 !     CHARACTER*3  TYP
  65       DIMENSION    IVAL(MAXJL)
  66       EQUIVALENCE  (CVAL,RVAL)
  67       REAL*8       RVAL,PKS,TEN !,VAL
  68
  69       DATA         TEN  /10./
  70
  71 !-----------------------------------------------------------------------
  72       PKS(NODE) = VAL(N,LUN)*TEN**ISC(NODE)-IRF(NODE)
  73 !-----------------------------------------------------------------------
  74
  75 !  CONVERT USER NUMBERS INTO SCALED INTEGERS
  76 !  -----------------------------------------
  77
  78       DO N=1,NVAL(LUN)
  79       NODE = INV(N,LUN)
  80       IF(ITP(NODE).EQ.1) THEN
  81          IVAL(N) = VAL(N,LUN)
  82       ELSEIF(TYP(NODE).EQ.'NUM') THEN
  83          IF(IBFMS(VAL(N,LUN)).EQ.0) THEN
  84             IVAL(N) = NINT(PKS(NODE))
  85          ELSE
  86             IVAL(N) = -1
  87          ENDIF
  88       ENDIF
  89       ENDDO
  90
  91 !  PACK THE USER ARRAY INTO THE SUBSET BUFFER
  92 !  ------------------------------------------
  93
  94       IBIT = 16
  95
  96       DO N=1,NVAL(LUN)
  97       NODE = INV(N,LUN)
  98       IF(ITP(NODE).LT.3) THEN
  99
 100 !        The value to be packed is numeric.
 101
 102          CALL PKB(IVAL(N),IBT(NODE),IBAY,IBIT)
 103       ELSE
 104
 105 !        The value to be packed is a character string.  If the string is
 106 !        longer than 8 characters, then only the first 8 will be packed
 107 !        by this routine, and a separate subsequent call to BUFR archive
 108 !        library subroutine WRITLC will be required to pack the
 109 !        remainder of the string.
 110
 111          RVAL = VAL(N,LUN)
 112          NBT = MIN(8,IBT(NODE)/8)
 113          CALL PKC(CVAL,NBT,IBAY,IBIT)
 114       ENDIF
 115       ENDDO
 116
 117       RETURN
 118       END SUBROUTINE WRTREE