ungrib/src/ngl/g2/getgb2p.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
   3      &                   EXTRACT,K,GRIBM,LENG,IRET)
   4 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   5 C
   6 C SUBPROGRAM: GETGB2P        FINDS AND EXTRACTS A GRIB MESSAGE
   7 C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 94-04-01
   8 C
   9 C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE.
  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   FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED.
  13 C   THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP
  14 C   AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
  15 C   PRODUCT DEFINTION SECTION PARAMETERS.  (A REQUESTED PARAMETER
  16 C   OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
  17 C   IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE
  18 C   GRIB FILE AND RETURNED.
  19 C   IF THE GRIB FIELD 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 2002-01-11  GILBERT     MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2
  26 C 2003-12-17  GILBERT     MODIFIED FROM GETGB2 TO RETURN PACKED GRIB2 MESSAGE.
  27 C
  28 C USAGE:    CALL GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
  29 C    &                  EXTRACT,K,GRIBM,LENG,IRET)
  30 C   INPUT ARGUMENTS:
  31 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
  32 C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING
  33 C                  THIS ROUTINE.
  34 C     LUGI         INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
  35 C                  IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE
  36 C                  CALLING THIS ROUTINE.
  37 C                  (=0 TO GET INDEX BUFFER FROM THE GRIB FILE)
  38 C     J            INTEGER NUMBER OF FIELDS TO SKIP
  39 C                  (=0 TO SEARCH FROM BEGINNING)
  40 C     JDISC        GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
  41 C                  ( IF = -1, ACCEPT ANY DISCIPLINE)
  42 C                  ( SEE CODE TABLE 0.0 )
  43 C                  0 - Meteorological products
  44 C                  1 - Hydrological products
  45 C                  2 - Land surface products
  46 C                  3 - Space products
  47 C                  10 - Oceanographic products
  48 C     JIDS()       INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
  49 C                  (=-9999 FOR WILDCARD)
  50 C            JIDS(1)   = IDENTIFICATION OF ORIGINATING CENTRE
  51 C                         ( SEE COMMON CODE TABLE C-1 )
  52 C            JIDS(2)   = IDENTIFICATION OF ORIGINATING SUB-CENTRE
  53 C            JIDS(3)   = GRIB MASTER TABLES VERSION NUMBER
  54 C                         ( SEE CODE TABLE 1.0 )
  55 C                       0 - Experimental
  56 C                       1 - Initial operational version number
  57 C            JIDS(4)   = GRIB LOCAL TABLES VERSION NUMBER
  58 C                         ( SEE CODE TABLE 1.1 )
  59 C                       0     - Local tables not used
  60 C                       1-254 - Number of local tables version used
  61 C            JIDS(5)   = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
  62 C                       0 - Analysis
  63 C                       1 - Start of forecast
  64 C                       2 - Verifying time of forecast
  65 C                       3 - Observation time
  66 C            JIDS(6)   = YEAR ( 4 DIGITS )
  67 C            JIDS(7)   = MONTH
  68 C            JIDS(8)   = DAY
  69 C            JIDS(9)   = HOUR
  70 C            JIDS(10)  = MINUTE
  71 C            JIDS(11)  = SECOND
  72 C            JIDS(12)  = PRODUCTION STATUS OF PROCESSED DATA
  73 C                         ( SEE CODE TABLE 1.3 )
  74 C                       0 - Operational products
  75 C                       1 - Operational test products
  76 C                       2 - Research products
  77 C                       3 - Re-analysis products
  78 C            JIDS(13)  = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
  79 C                       0  - Analysis products
  80 C                       1  - Forecast products
  81 C                       2  - Analysis and forecast products
  82 C                       3  - Control forecast products
  83 C                       4  - Perturbed forecast products
  84 C                       5  - Control and perturbed forecast products
  85 C                       6  - Processed satellite observations
  86 C                       7  - Processed radar observations
  87 C     JPDTN        INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
  88 C                  ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY )
  89 C     JPDT()       INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
  90 C                  TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
  91 C                  (=-9999 FOR WILDCARD)
  92 C     JGDTN        INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
  93 C                  ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY )
  94 C     JGDT()       INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
  95 C                  TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
  96 C                  (=-9999 FOR WILDCARD)
  97 C     EXTRACT       LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2
  98 C                   MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE
  99 C                   GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD.
 100 C                  .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED
 101 C                           FIELD.
 102 C                  .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE
 103 C                            REQUESTED FIELD.
 104 C
 105 C   OUTPUT ARGUMENTS:
 106 C     K            INTEGER FIELD NUMBER RETURNED.
 107 C     GRIBM         RETURNED GRIB MESSAGE.
 108 C     LENG         LENGTH OF RETURNED GRIB MESSAGE IN BYTES.
 109 C     IRET         INTEGER RETURN CODE
 110 C                    0      ALL OK
 111 C                    96     ERROR READING INDEX FILE
 112 C                    97     ERROR READING GRIB FILE
 113 C                    99     REQUEST NOT FOUND
 114 C
 115 C SUBPROGRAMS CALLED:
 116 C   GETG2I          READ INDEX FILE
 117 C   GETG2IR         READ INDEX BUFFER FROM GRIB FILE
 118 C   GETGB2S        SEARCH INDEX RECORDS
 119 C   GETGB2RP        READ A PACKED GRIB RECORD
 120 C   GF_FREE        FREES MEMORY USED BY GFLD  ( SEE REMARKS )
 121 C
 122 C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
 123 C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
 124 C
 125 C   Note that derived type gribfield contains pointers to many
 126 C   arrays of data.  The memory for these arrays is allocated
 127 C   when the values in the arrays are set, to help minimize
 128 C   problems with array overloading.  Because of this users
 129 C   are encouraged to free up this memory, when it is no longer
 130 C   needed, by an explicit call to subroutine gf_free.
 131 C   ( i.e.   CALL GF_FREE(GFLD) )
 132 C
 133 C ATTRIBUTES:
 134 C   LANGUAGE: FORTRAN 90
 135 C
 136 C$$$
 137       USE GRIB_MOD
 138
 139       INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN
 140       INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*)
 141       LOGICAL,INTENT(IN) :: EXTRACT
 142       INTEGER,INTENT(OUT) :: K,IRET,LENG
 143       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
 144
 145       TYPE(GRIBFIELD) :: GFLD
 146
 147       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
 148       PARAMETER(MSK1=32000,MSK2=4000)
 149
 150       SAVE CBUF,NLEN,NNUM
 151       DATA LUX/0/
 152 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 153 C  DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
 154       INTERFACE
 155          SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
 156             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
 157             INTEGER,INTENT(IN) :: LUGI
 158             INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
 159          END SUBROUTINE GETG2I
 160          SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
 161      &                      NMESS,IRET)
 162             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
 163             INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
 164             INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
 165          END SUBROUTINE GETG2IR
 166          SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
 167             INTEGER,INTENT(IN) :: LUGB
 168             CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
 169             LOGICAL,INTENT(IN) :: EXTRACT
 170             INTEGER,INTENT(OUT) :: LENG,IRET
 171             CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
 172          END SUBROUTINE GETGB2RP
 173       END INTERFACE
 174
 175 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 176 C  DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
 177       IRGI=0
 178       IF(LUGI.GT.0.AND.LUGI.NE.LUX) THEN
 179         CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRGI)
 180         LUX=LUGI
 181       ELSEIF(LUGI.LE.0.AND.LUGB.NE.LUX) THEN
 182         MSKP=0
 183         CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,CBUF,NLEN,NNUM,NMESS,IRGI)
 184         LUX=LUGB
 185       ENDIF
 186       IF(IRGI.GT.1) THEN
 187         IRET=96
 188         LUX=0
 189         RETURN
 190       ENDIF
 191 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 192 C  SEARCH INDEX BUFFER
 193       CALL GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
 194      &             JK,GFLD,LPOS,IRGS)
 195       IF(IRGS.NE.0) THEN
 196         IRET=99
 197         CALL GF_FREE(GFLD)
 198         RETURN
 199       ENDIF
 200 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 201 C  EXTRACT GRIB MESSAGE FROM FILE
 202       CALL GETGB2RP(LUGB,CBUF(LPOS:),EXTRACT,GRIBM,LENG,IRET)
 203 !      IF ( EXTRACT ) THEN
 204 !         PRINT *,'NOT SUPPOSED TO BE HERE.'
 205 !      ELSE
 206 !         IPOS=(LPOS+3)*8
 207 !         CALL GBYTE(CBUF,ISKIP,IPOS,32)     ! BYTES TO SKIP IN FILE
 208 !         IPOS=IPOS+(32*8)
 209 !         CALL GBYTE(CBUF,LENG,IPOS,32)      ! LENGTH OF GRIB MESSAGE
 210 !         IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
 211 !         CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM)
 212 !         IF ( LENG .NE. LREAD ) THEN
 213 !            IRET=97
 214 !            CALL GF_FREE(GFLD)
 215 !            RETURN
 216 !         ENDIF
 217 !      ENDIF
 218 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 219       K=JK
 220       CALL GF_FREE(GFLD)
 221 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 222       RETURN
 223       END