hwrf-baseline-20120103-1354/ungrib/src/ngl/w3/putgbex.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE PUTGBEX(LUGB,KF,KPDS,KGDS,KENS,
   3      &                   KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET)
   4 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   5 C
   6 C SUBPROGRAM: PUTGBE         PACKS AND WRITES A GRIB MESSAGE
   7 C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
   8 C
   9 C ABSTRACT: PACK AND WRITE A GRIB MESSAGE.
  10 C   THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C   94-04-01  IREDELL
  14 C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
  15 C   97-02-11  Y.ZHU       INCLUDED PROBABILITY AND CLUSTER ARGUMENTS
  16 C
  17 C USAGE:    CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,
  18 C    &                   KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET)
  19 C   INPUT ARGUMENTS:
  20 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
  21 C     KF           INTEGER NUMBER OF DATA POINTS
  22 C     KPDS         INTEGER (200) PDS PARAMETERS
  23 C          (1)   - ID OF CENTER
  24 C          (2)   - GENERATING PROCESS ID NUMBER
  25 C          (3)   - GRID DEFINITION
  26 C          (4)   - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
  27 C          (5)   - INDICATOR OF PARAMETER
  28 C          (6)   - TYPE OF LEVEL
  29 C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
  30 C          (8)   - YEAR INCLUDING (CENTURY-1)
  31 C          (9)   - MONTH OF YEAR
  32 C          (10)  - DAY OF MONTH
  33 C          (11)  - HOUR OF DAY
  34 C          (12)  - MINUTE OF HOUR
  35 C          (13)  - INDICATOR OF FORECAST TIME UNIT
  36 C          (14)  - TIME RANGE 1
  37 C          (15)  - TIME RANGE 2
  38 C          (16)  - TIME RANGE FLAG
  39 C          (17)  - NUMBER INCLUDED IN AVERAGE
  40 C          (18)  - VERSION NR OF GRIB SPECIFICATION
  41 C          (19)  - VERSION NR OF PARAMETER TABLE
  42 C          (20)  - NR MISSING FROM AVERAGE/ACCUMULATION
  43 C          (21)  - CENTURY OF REFERENCE TIME OF DATA
  44 C          (22)  - UNITS DECIMAL SCALE FACTOR
  45 C          (23)  - SUBCENTER NUMBER
  46 C          (24)  - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS
  47 C                  128 IF FORECAST FIELD ERROR
  48 C                   64 IF BIAS CORRECTED FCST FIELD
  49 C                   32 IF SMOOTHED FIELD
  50 C                  WARNING: CAN BE COMBINATION OF MORE THAN 1
  51 C          (25)  - PDS BYTE 30, NOT USED
  52 C     KGDS         INTEGER (200) GDS PARAMETERS
  53 C          (1)   - DATA REPRESENTATION TYPE
  54 C          (19)  - NUMBER OF VERTICAL COORDINATE PARAMETERS
  55 C          (20)  - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
  56 C                  PARAMETERS
  57 C                  OR
  58 C                  OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
  59 C                  IN EACH ROW
  60 C                  OR
  61 C                  255 IF NEITHER ARE PRESENT
  62 C          (21)  - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
  63 C          (22)  - NUMBER OF WORDS IN EACH ROW
  64 C       LATITUDE/LONGITUDE GRIDS
  65 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
  66 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
  67 C          (4)   - LA(1) LATITUDE OF ORIGIN
  68 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  69 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
  70 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
  71 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
  72 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
  73 C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
  74 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
  75 C       GAUSSIAN  GRIDS
  76 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
  77 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
  78 C          (4)   - LA(1) LATITUDE OF ORIGIN
  79 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  80 C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
  81 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
  82 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
  83 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
  84 C          (10)  - N - NR OF CIRCLES POLE TO EQUATOR
  85 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
  86 C          (12)  - NV - NR OF VERT COORD PARAMETERS
  87 C          (13)  - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
  88 C                             OR
  89 C                  PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
  90 C                       EACH ROW (IF NO VERT COORD PARAMETERS
  91 C                       ARE PRESENT
  92 C                             OR
  93 C                  255 IF NEITHER ARE PRESENT
  94 C       POLAR STEREOGRAPHIC GRIDS
  95 C          (2)   - N(I) NR POINTS ALONG LAT CIRCLE
  96 C          (3)   - N(J) NR POINTS ALONG LON CIRCLE
  97 C          (4)   - LA(1) LATITUDE OF ORIGIN
  98 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  99 C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
 100 C          (7)   - LOV GRID ORIENTATION
 101 C          (8)   - DX - X DIRECTION INCREMENT
 102 C          (9)   - DY - Y DIRECTION INCREMENT
 103 C          (10)  - PROJECTION CENTER FLAG
 104 C          (11)  - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
 105 C       SPHERICAL HARMONIC COEFFICIENTS
 106 C          (2)   - J PENTAGONAL RESOLUTION PARAMETER
 107 C          (3)   - K      "          "         "
 108 C          (4)   - M      "          "         "
 109 C          (5)   - REPRESENTATION TYPE
 110 C          (6)   - COEFFICIENT STORAGE MODE
 111 C       MERCATOR GRIDS
 112 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
 113 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
 114 C          (4)   - LA(1) LATITUDE OF ORIGIN
 115 C          (5)   - LO(1) LONGITUDE OF ORIGIN
 116 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
 117 C          (7)   - LA(2) LATITUDE OF LAST GRID POINT
 118 C          (8)   - LO(2) LONGITUDE OF LAST GRID POINT
 119 C          (9)   - LATIT - LATITUDE OF PROJECTION INTERSECTION
 120 C          (10)  - RESERVED
 121 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 122 C          (12)  - LONGITUDINAL DIR GRID LENGTH
 123 C          (13)  - LATITUDINAL DIR GRID LENGTH
 124 C       LAMBERT CONFORMAL GRIDS
 125 C          (2)   - NX NR POINTS ALONG X-AXIS
 126 C          (3)   - NY NR POINTS ALONG Y-AXIS
 127 C          (4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
 128 C          (5)   - LO1 LON OF ORIGIN (LOWER LEFT)
 129 C          (6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
 130 C          (7)   - LOV - ORIENTATION OF GRID
 131 C          (8)   - DX - X-DIR INCREMENT
 132 C          (9)   - DY - Y-DIR INCREMENT
 133 C          (10)  - PROJECTION CENTER FLAG
 134 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 135 C          (12)  - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
 136 C          (13)  - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
 137 C     KENS         INTEGER (200) ENSEMBLE PDS PARMS
 138 C          (1)   - APPLICATION IDENTIFIER
 139 C          (2)   - ENSEMBLE TYPE
 140 C          (3)   - ENSEMBLE IDENTIFIER
 141 C          (4)   - PRODUCT IDENTIFIER
 142 C          (5)   - SMOOTHING FLAG
 143 C     KPROB        INTEGER (2) PROBABILITY ENSEMBLE PARMS
 144 C     XPROB        REAL    (2) PROBABILITY ENSEMBLE PARMS
 145 C     KCLUST       INTEGER (16) CLUSTER ENSEMBLE PARMS
 146 C     KMEMBR       INTEGER (8) CLUSTER ENSEMBLE PARMS
 147 C     LB           LOGICAL*1 (KF) BITMAP IF PRESENT
 148 C     F            REAL (KF) DATA
 149 C   OUTPUT ARGUMENTS:
 150 C     IRET         INTEGER RETURN CODE
 151 C                    0      ALL OK
 152 C                    OTHER  W3FI72 GRIB PACKER RETURN CODE
 153 C
 154 C SUBPROGRAMS CALLED:
 155 C   R63W72         MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS
 156 C   GETBIT         GET NUMBER OF BITS AND ROUND DATA
 157 C   W3FI72         PACK GRIB
 158 C   WRYTE          WRITE DATA
 159 C
 160 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
 161 C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
 162 C
 163 C ATTRIBUTES:
 164 C   LANGUAGE: FORTRAN 77
 165 C   MACHINE:  CRAY, WORKSTATIONS
 166 C
 167 C$$$
 168       INTEGER KPDS(200),KGDS(200),KENS(200)
 169       INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
 170       REAL XPROB(2)
 171       LOGICAL*1 LB(KF)
 172       REAL F(KF)
 173       PARAMETER(MAXBIT=16)
 174       INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
 175       REAL FR(KF)
 176       CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
 177 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 178 C  GET W3FI72 PARAMETERS
 179       CALL R63W72(KPDS,KGDS,IPDS,IGDS)
 180       IBDS=0
 181 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 182 C  COUNT VALID DATA
 183       KBM=KF
 184       IF(IPDS(7).NE.0) THEN
 185         KBM=0
 186         DO I=1,KF
 187           IF(LB(I)) THEN
 188             IBM(I)=1
 189             KBM=KBM+1
 190           ELSE
 191             IBM(I)=0
 192           ENDIF
 193         ENDDO
 194         IF(KBM.EQ.KF) IPDS(7)=0
 195       ENDIF
 196 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 197 C  GET NUMBER OF BITS AND ROUND DATA
 198       IF(KBM.EQ.0) THEN
 199         DO I=1,KF
 200           FR(I)=0.
 201         ENDDO
 202         NBIT=0
 203       ELSE
 204         CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT)
 205         NBIT=MIN(NBIT,MAXBIT)
 206       ENDIF
 207 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 208 C  CREATE PRODUCT DEFINITION SECTION
 209       CALL W3FI68(IPDS,PDS)
 210       IF(IPDS(24).EQ.2) THEN
 211         ILAST=86
 212         CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS)
 213       ENDIF
 214 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 215 C  PACK AND WRITE GRIB DATA
 216       CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS,
 217      &            1,255,IGDS,0,0,IBM,KF,IBDS,
 218      &            KFO,GRIB,LGRIB,IRET)
 219       IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB)
 220 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 221       RETURN
 222       END