ungrib/src/ngl/w3/getgbexm.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
   3      &                    MBUF,CBUF,NLEN,NNUM,MNUM,
   4      &                    KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR,
   5      &                    LB,F,IRET)
   6 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   7 C
   8 C SUBPROGRAM: GETGBEXM       FINDS AND UNPACKS A GRIB MESSAGE
   9 C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
  10 C
  11 C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE.
  12 C   READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
  13 C   TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
  14 C   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED.
  15 C   THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP
  16 C   AND THE UNPACKED PDS AND GDS PARAMETERS.  (A REQUESTED PARAMETER
  17 C   OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
  18 C   IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE
  19 C   GRIB FILE AND UNPACKED.  ITS MESSAGE NUMBER IS RETURNED ALONG WITH
  20 C   THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY),
  21 C   AND THE UNPACKED DATA.  IF THE GRIB MESSAGE IS NOT FOUND, THEN THE
  22 C   RETURN CODE WILL BE NONZERO.
  23 C
  24 C PROGRAM HISTORY LOG:
  25 C   94-04-01  IREDELL
  26 C   95-10-31  IREDELL     MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
  27 C                         AND ALLOWED FOR UNSPECIFIED INDEX FILE
  28 C   97-02-11  Y.ZHU       INCLUDED PROBABILITY AND CLUSTER ARGUMENTS
  29 C
  30 C USAGE:    CALL GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
  31 C    &                    MBUF,CBUF,NLEN,NNUM,MNUM,
  32 C    &                    KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR,
  33 C    &                    LB,F,IRET)
  34 C   INPUT ARGUMENTS:
  35 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
  36 C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE
  37 C                  (=0 TO GET INDEX BUFFER FROM THE GRIB FILE)
  38 C     JF           INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK
  39 C     J            INTEGER NUMBER OF MESSAGES TO SKIP
  40 C                  (=0 TO SEARCH FROM BEGINNING)
  41 C                  (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES)
  42 C     JPDS         INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH
  43 C                  (=-1 FOR WILDCARD)
  44 C          (1)   - ID OF CENTER
  45 C          (2)   - GENERATING PROCESS ID NUMBER
  46 C          (3)   - GRID DEFINITION
  47 C          (4)   - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
  48 C          (5)   - INDICATOR OF PARAMETER
  49 C          (6)   - TYPE OF LEVEL
  50 C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
  51 C          (8)   - YEAR INCLUDING (CENTURY-1)
  52 C          (9)   - MONTH OF YEAR
  53 C          (10)  - DAY OF MONTH
  54 C          (11)  - HOUR OF DAY
  55 C          (12)  - MINUTE OF HOUR
  56 C          (13)  - INDICATOR OF FORECAST TIME UNIT
  57 C          (14)  - TIME RANGE 1
  58 C          (15)  - TIME RANGE 2
  59 C          (16)  - TIME RANGE FLAG
  60 C          (17)  - NUMBER INCLUDED IN AVERAGE
  61 C          (18)  - VERSION NR OF GRIB SPECIFICATION
  62 C          (19)  - VERSION NR OF PARAMETER TABLE
  63 C          (20)  - NR MISSING FROM AVERAGE/ACCUMULATION
  64 C          (21)  - CENTURY OF REFERENCE TIME OF DATA
  65 C          (22)  - UNITS DECIMAL SCALE FACTOR
  66 C          (23)  - SUBCENTER NUMBER
  67 C          (24)  - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS
  68 C                  128 IF FORECAST FIELD ERROR
  69 C                   64 IF BIAS CORRECTED FCST FIELD
  70 C                   32 IF SMOOTHED FIELD
  71 C                  WARNING: CAN BE COMBINATION OF MORE THAN 1
  72 C          (25)  - PDS BYTE 30, NOT USED
  73 C     JGDS         INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH
  74 C                  (ONLY SEARCHED IF JPDS(3)=255)
  75 C                  (=-1 FOR WILDCARD)
  76 C          (1)   - DATA REPRESENTATION TYPE
  77 C          (19)  - NUMBER OF VERTICAL COORDINATE PARAMETERS
  78 C          (20)  - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
  79 C                  PARAMETERS
  80 C                  OR
  81 C                  OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
  82 C                  IN EACH ROW
  83 C                  OR
  84 C                  255 IF NEITHER ARE PRESENT
  85 C          (21)  - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
  86 C          (22)  - NUMBER OF WORDS IN EACH ROW
  87 C       LATITUDE/LONGITUDE GRIDS
  88 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
  89 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
  90 C          (4)   - LA(1) LATITUDE OF ORIGIN
  91 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  92 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
  93 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
  94 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
  95 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
  96 C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
  97 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
  98 C       GAUSSIAN  GRIDS
  99 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
 100 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
 101 C          (4)   - LA(1) LATITUDE OF ORIGIN
 102 C          (5)   - LO(1) LONGITUDE OF ORIGIN
 103 C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
 104 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
 105 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
 106 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
 107 C          (10)  - N - NR OF CIRCLES POLE TO EQUATOR
 108 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 109 C          (12)  - NV - NR OF VERT COORD PARAMETERS
 110 C          (13)  - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
 111 C                             OR
 112 C                  PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
 113 C                       EACH ROW (IF NO VERT COORD PARAMETERS
 114 C                       ARE PRESENT
 115 C                             OR
 116 C                  255 IF NEITHER ARE PRESENT
 117 C       POLAR STEREOGRAPHIC GRIDS
 118 C          (2)   - N(I) NR POINTS ALONG LAT CIRCLE
 119 C          (3)   - N(J) NR POINTS ALONG LON CIRCLE
 120 C          (4)   - LA(1) LATITUDE OF ORIGIN
 121 C          (5)   - LO(1) LONGITUDE OF ORIGIN
 122 C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
 123 C          (7)   - LOV GRID ORIENTATION
 124 C          (8)   - DX - X DIRECTION INCREMENT
 125 C          (9)   - DY - Y DIRECTION INCREMENT
 126 C          (10)  - PROJECTION CENTER FLAG
 127 C          (11)  - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
 128 C       SPHERICAL HARMONIC COEFFICIENTS
 129 C          (2)   - J PENTAGONAL RESOLUTION PARAMETER
 130 C          (3)   - K      "          "         "
 131 C          (4)   - M      "          "         "
 132 C          (5)   - REPRESENTATION TYPE
 133 C          (6)   - COEFFICIENT STORAGE MODE
 134 C       MERCATOR GRIDS
 135 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
 136 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
 137 C          (4)   - LA(1) LATITUDE OF ORIGIN
 138 C          (5)   - LO(1) LONGITUDE OF ORIGIN
 139 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
 140 C          (7)   - LA(2) LATITUDE OF LAST GRID POINT
 141 C          (8)   - LO(2) LONGITUDE OF LAST GRID POINT
 142 C          (9)   - LATIT - LATITUDE OF PROJECTION INTERSECTION
 143 C          (10)  - RESERVED
 144 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 145 C          (12)  - LONGITUDINAL DIR GRID LENGTH
 146 C          (13)  - LATITUDINAL DIR GRID LENGTH
 147 C       LAMBERT CONFORMAL GRIDS
 148 C          (2)   - NX NR POINTS ALONG X-AXIS
 149 C          (3)   - NY NR POINTS ALONG Y-AXIS
 150 C          (4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
 151 C          (5)   - LO1 LON OF ORIGIN (LOWER LEFT)
 152 C          (6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
 153 C          (7)   - LOV - ORIENTATION OF GRID
 154 C          (8)   - DX - X-DIR INCREMENT
 155 C          (9)   - DY - Y-DIR INCREMENT
 156 C          (10)  - PROJECTION CENTER FLAG
 157 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 158 C          (12)  - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
 159 C          (13)  - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
 160 C     JENS         INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH
 161 C                  (ONLY SEARCHED IF JPDS(23)=2)
 162 C                  (=-1 FOR WILDCARD)
 163 C          (1)   - APPLICATION IDENTIFIER
 164 C          (2)   - ENSEMBLE TYPE
 165 C          (3)   - ENSEMBLE IDENTIFIER
 166 C          (4)   - PRODUCT IDENTIFIER
 167 C          (5)   - SMOOTHING FLAG
 168 C     MBUF         INTEGER LENGTH OF INDEX BUFFER IN BYTES
 169 C     CBUF         CHARACTER*1 (MBUF) INDEX BUFFER
 170 C                  (INITIALIZE BY SETTING J=-1)
 171 C     NLEN         INTEGER LENGTH OF EACH INDEX RECORD IN BYTES
 172 C                  (INITIALIZE BY SETTING J=-1)
 173 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
 174 C                  (INITIALIZE BY SETTING J=-1)
 175 C     MNUM         INTEGER NUMBER OF INDEX RECORDS SKIPPED
 176 C                  (INITIALIZE BY SETTING J=-1)
 177 C   OUTPUT ARGUMENTS:
 178 C     CBUF         CHARACTER*1 (MBUF) INDEX BUFFER
 179 C     NLEN         INTEGER LENGTH OF EACH INDEX RECORD IN BYTES
 180 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
 181 C     MNUM         INTEGER NUMBER OF INDEX RECORDS SKIPPED
 182 C     KF           INTEGER NUMBER OF DATA POINTS UNPACKED
 183 C     K            INTEGER MESSAGE NUMBER UNPACKED
 184 C                  (CAN BE SAME AS J IN CALLING PROGRAM
 185 C                  IN ORDER TO FACILITATE MULTIPLE SEARCHES)
 186 C     KPDS         INTEGER (200) UNPACKED PDS PARAMETERS
 187 C     KGDS         INTEGER (200) UNPACKED GDS PARAMETERS
 188 C     KENS         INTEGER (200) UNPACKED ENSEMBLE PDS PARMS
 189 C     KPROB        INTEGER (2) PROBABILITY ENSEMBLE PARMS
 190 C     XPROB        REAL    (2) PROBABILITY ENSEMBLE PARMS
 191 C     KCLUST       INTEGER (16) CLUSTER ENSEMBLE PARMS
 192 C     KMEMBR       INTEGER (8) CLUSTER ENSEMBLE PARMS
 193 C     LB           LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT
 194 C     F            REAL (KF) UNPACKED DATA
 195 C     IRET         INTEGER RETURN CODE
 196 C                    0      ALL OK
 197 C                    96     ERROR READING INDEX FILE
 198 C                    97     ERROR READING GRIB FILE
 199 C                    98     NUMBER OF DATA POINTS GREATER THAN JF
 200 C                    99     REQUEST NOT FOUND
 201 C                    OTHER  W3FI63 GRIB UNPACKER RETURN CODE
 202 C
 203 C SUBPROGRAMS CALLED:
 204 C   GETGI          READ INDEX FILE
 205 C   GETGIR         READ INDEX BUFFER FROM GRIB FILE
 206 C   GETGB1S        SEARCH INDEX RECORDS
 207 C   GETGB1RE       READ AND UNPACK GRIB RECORD
 208 C   LENGDS         RETURN THE LENGTH OF A GRID
 209 C
 210 C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
 211 C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
 212 C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
 213 C
 214 C ATTRIBUTES:
 215 C   LANGUAGE: FORTRAN 77
 216 C   MACHINE:  CRAY, WORKSTATIONS
 217 C
 218 C$$$
 219       INTEGER JPDS(200),JGDS(200),JENS(200)
 220       INTEGER KPDS(200),KGDS(200),KENS(200)
 221       INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
 222       REAL XPROB(2)
 223       CHARACTER CBUF(MBUF)
 224       LOGICAL*1 LB(JF)
 225       REAL F(JF)
 226       PARAMETER(MSK1=32000,MSK2=4000)
 227 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 228 C  SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
 229       IF(J.GE.0) THEN
 230         IF(MNUM.GE.0) THEN
 231           IRGI=0
 232         ELSE
 233           MNUM=-1-MNUM
 234           IRGI=1
 235         ENDIF
 236         JR=J-MNUM
 237         IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN
 238           CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS,
 239      &                 KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS)
 240           IF(IRGS.EQ.0) K=KR+MNUM
 241           IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM
 242           IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM
 243         ELSE
 244           MNUM=J
 245           IRGI=1
 246           IRGS=1
 247         ENDIF
 248       ELSE
 249         MNUM=-1-J
 250         IRGI=1
 251         IRGS=1
 252       ENDIF
 253 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 254 C  READ AND SEARCH NEXT INDEX BUFFER
 255       JR=0
 256       DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1)
 257         IF(LUGI.GT.0) THEN
 258           CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI)
 259         ELSE
 260           CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI)
 261         ENDIF
 262         IF(IRGI.LE.1) THEN
 263           CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS,
 264      &                 KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS)
 265           IF(IRGS.EQ.0) K=KR+MNUM
 266           IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM
 267           IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM
 268         ENDIF
 269       ENDDO
 270 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 271 C  READ AND UNPACK GRIB RECORD
 272       IF(IRGI.GT.1) THEN
 273         IRET=96
 274       ELSEIF(IRGS.NE.0) THEN
 275         IRET=99
 276       ELSEIF(LENGDS(KGDS).GT.JF) THEN
 277         IRET=98
 278       ELSE
 279         CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,
 280      &                KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET)
 281       ENDIF
 282 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 283       RETURN
 284       END