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

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETGBH(LUGB,LUGI,J,JPDS,JGDS,
   3      &                  KG,KF,K,KPDS,KGDS,IRET)
   4 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   5 C
   6 C SUBPROGRAM: GETGBH         FINDS A GRIB MESSAGE
   7 C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
   8 C
   9 C ABSTRACT: FIND A GRIB MESSAGE.
  10 C   READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
  11 C   TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
  12 C   (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.)
  13 C   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED.
  14 C   THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP
  15 C   AND THE UNPACKED PDS AND GDS PARAMETERS.  (A REQUESTED PARAMETER
  16 C   OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
  17 C   IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS
  18 C   RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS.  IF THE
  19 C   GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO.
  20 C
  21 C PROGRAM HISTORY LOG:
  22 C   94-04-01  IREDELL
  23 C   95-10-31  IREDELL     MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
  24 C                         AND ALLOWED FOR UNSPECIFIED INDEX FILE
  25 C
  26 C USAGE:    CALL GETGBH(LUGB,LUGI,J,JPDS,JGDS,
  27 C    &                  KG,KF,K,KPDS,KGDS,IRET)
  28 C   INPUT ARGUMENTS:
  29 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE
  30 C                  (ONLY USED IF LUGI=0)
  31 C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE
  32 C                  (=0 TO GET INDEX BUFFER FROM THE GRIB FILE)
  33 C     J            INTEGER NUMBER OF MESSAGES TO SKIP
  34 C                  (=0 TO SEARCH FROM BEGINNING)
  35 C                  (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES)
  36 C     JPDS         INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH
  37 C                  (=-1 FOR WILDCARD)
  38 C          (1)   - ID OF CENTER
  39 C          (2)   - GENERATING PROCESS ID NUMBER
  40 C          (3)   - GRID DEFINITION
  41 C          (4)   - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
  42 C          (5)   - INDICATOR OF PARAMETER
  43 C          (6)   - TYPE OF LEVEL
  44 C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
  45 C          (8)   - YEAR INCLUDING (CENTURY-1)
  46 C          (9)   - MONTH OF YEAR
  47 C          (10)  - DAY OF MONTH
  48 C          (11)  - HOUR OF DAY
  49 C          (12)  - MINUTE OF HOUR
  50 C          (13)  - INDICATOR OF FORECAST TIME UNIT
  51 C          (14)  - TIME RANGE 1
  52 C          (15)  - TIME RANGE 2
  53 C          (16)  - TIME RANGE FLAG
  54 C          (17)  - NUMBER INCLUDED IN AVERAGE
  55 C          (18)  - VERSION NR OF GRIB SPECIFICATION
  56 C          (19)  - VERSION NR OF PARAMETER TABLE
  57 C          (20)  - NR MISSING FROM AVERAGE/ACCUMULATION
  58 C          (21)  - CENTURY OF REFERENCE TIME OF DATA
  59 C          (22)  - UNITS DECIMAL SCALE FACTOR
  60 C          (23)  - SUBCENTER NUMBER
  61 C          (24)  - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS
  62 C                  128 IF FORECAST FIELD ERROR
  63 C                   64 IF BIAS CORRECTED FCST FIELD
  64 C                   32 IF SMOOTHED FIELD
  65 C                  WARNING: CAN BE COMBINATION OF MORE THAN 1
  66 C          (25)  - PDS BYTE 30, NOT USED
  67 C     JGDS         INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH
  68 C                  (ONLY SEARCHED IF JPDS(3)=255)
  69 C                  (=-1 FOR WILDCARD)
  70 C          (1)   - DATA REPRESENTATION TYPE
  71 C          (19)  - NUMBER OF VERTICAL COORDINATE PARAMETERS
  72 C          (20)  - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
  73 C                  PARAMETERS
  74 C                  OR
  75 C                  OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
  76 C                  IN EACH ROW
  77 C                  OR
  78 C                  255 IF NEITHER ARE PRESENT
  79 C          (21)  - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
  80 C          (22)  - NUMBER OF WORDS IN EACH ROW
  81 C       LATITUDE/LONGITUDE GRIDS
  82 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
  83 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
  84 C          (4)   - LA(1) LATITUDE OF ORIGIN
  85 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  86 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
  87 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
  88 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
  89 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
  90 C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
  91 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
  92 C       GAUSSIAN  GRIDS
  93 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
  94 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
  95 C          (4)   - LA(1) LATITUDE OF ORIGIN
  96 C          (5)   - LO(1) LONGITUDE OF ORIGIN
  97 C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
  98 C          (7)   - LA(2) LATITUDE OF EXTREME POINT
  99 C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
 100 C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
 101 C          (10)  - N - NR OF CIRCLES POLE TO EQUATOR
 102 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 103 C          (12)  - NV - NR OF VERT COORD PARAMETERS
 104 C          (13)  - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
 105 C                             OR
 106 C                  PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
 107 C                       EACH ROW (IF NO VERT COORD PARAMETERS
 108 C                       ARE PRESENT
 109 C                             OR
 110 C                  255 IF NEITHER ARE PRESENT
 111 C       POLAR STEREOGRAPHIC GRIDS
 112 C          (2)   - N(I) NR POINTS ALONG LAT CIRCLE
 113 C          (3)   - N(J) NR POINTS ALONG LON CIRCLE
 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)   - LOV GRID ORIENTATION
 118 C          (8)   - DX - X DIRECTION INCREMENT
 119 C          (9)   - DY - Y DIRECTION INCREMENT
 120 C          (10)  - PROJECTION CENTER FLAG
 121 C          (11)  - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
 122 C       SPHERICAL HARMONIC COEFFICIENTS
 123 C          (2)   - J PENTAGONAL RESOLUTION PARAMETER
 124 C          (3)   - K      "          "         "
 125 C          (4)   - M      "          "         "
 126 C          (5)   - REPRESENTATION TYPE
 127 C          (6)   - COEFFICIENT STORAGE MODE
 128 C       MERCATOR GRIDS
 129 C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
 130 C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
 131 C          (4)   - LA(1) LATITUDE OF ORIGIN
 132 C          (5)   - LO(1) LONGITUDE OF ORIGIN
 133 C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
 134 C          (7)   - LA(2) LATITUDE OF LAST GRID POINT
 135 C          (8)   - LO(2) LONGITUDE OF LAST GRID POINT
 136 C          (9)   - LATIT - LATITUDE OF PROJECTION INTERSECTION
 137 C          (10)  - RESERVED
 138 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 139 C          (12)  - LONGITUDINAL DIR GRID LENGTH
 140 C          (13)  - LATITUDINAL DIR GRID LENGTH
 141 C       LAMBERT CONFORMAL GRIDS
 142 C          (2)   - NX NR POINTS ALONG X-AXIS
 143 C          (3)   - NY NR POINTS ALONG Y-AXIS
 144 C          (4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
 145 C          (5)   - LO1 LON OF ORIGIN (LOWER LEFT)
 146 C          (6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
 147 C          (7)   - LOV - ORIENTATION OF GRID
 148 C          (8)   - DX - X-DIR INCREMENT
 149 C          (9)   - DY - Y-DIR INCREMENT
 150 C          (10)  - PROJECTION CENTER FLAG
 151 C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
 152 C          (12)  - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
 153 C          (13)  - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
 154 C   OUTPUT ARGUMENTS:
 155 C     KG           INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE
 156 C     KF           INTEGER NUMBER OF DATA POINTS IN THE MESSAGE
 157 C     K            INTEGER MESSAGE NUMBER UNPACKED
 158 C                  (CAN BE SAME AS J IN CALLING PROGRAM
 159 C                  IN ORDER TO FACILITATE MULTIPLE SEARCHES)
 160 C     KPDS         INTEGER (200) UNPACKED PDS PARAMETERS
 161 C     KGDS         INTEGER (200) UNPACKED GDS PARAMETERS
 162 C     IRET         INTEGER RETURN CODE
 163 C                    0      ALL OK
 164 C                    96     ERROR READING INDEX FILE
 165 C                    99     REQUEST NOT FOUND
 166 C
 167 C SUBPROGRAMS CALLED:
 168 C   GETGBMH        FIND GRIB MESSAGE
 169 C
 170 C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT
 171 C   WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF
 172 C   LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMH AS BELOW,
 173 C   ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR.
 174 C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
 175 C
 176 C ATTRIBUTES:
 177 C   LANGUAGE: FORTRAN 77
 178 C   MACHINE:  CRAY, WORKSTATIONS
 179 C
 180 C$$$
 181       INTEGER JPDS(200),JGDS(200)
 182       INTEGER KPDS(200),KGDS(200)
 183       PARAMETER(MBUF=256*1024)
 184       CHARACTER CBUF(MBUF)
 185       SAVE CBUF,NLEN,NNUM,MNUM
 186       DATA LUX/0/
 187 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 188 C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
 189       IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN
 190         LUX=LUGI
 191         JJ=MIN(J,-1-J)
 192       ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN
 193         LUX=LUGB
 194         JJ=MIN(J,-1-J)
 195       ELSE
 196         JJ=J
 197       ENDIF
 198 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 199 C  FIND AND UNPACK GRIB MESSAGE
 200       CALL GETGBMH(LUGB,LUGI,JJ,JPDS,JGDS,
 201      &             MBUF,CBUF,NLEN,NNUM,MNUM,
 202      &             KG,KF,K,KPDS,KGDS,IRET)
 203       IF(IRET.EQ.96) LUX=0
 204 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 205       RETURN
 206       END