C-----------------------------------------------------------------------
SUBROUTINE GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,,5
& EXTRACT,K,GRIBM,LENG,IRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: GETGB2P FINDS AND EXTRACTS A GRIB MESSAGE
C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01
C
C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE.
C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF)
C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE.
C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED.
C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP
C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER
C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
C IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE
C GRIB FILE AND RETURNED.
C IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO.
C
C PROGRAM HISTORY LOG:
C 94-04-01 IREDELL
C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS
C AND ALLOWED FOR UNSPECIFIED INDEX FILE
C 2002-01-11 GILBERT MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2
C 2003-12-17 GILBERT MODIFIED FROM GETGB2 TO RETURN PACKED GRIB2 MESSAGE.
C
C USAGE: CALL GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
C & EXTRACT,K,GRIBM,LENG,IRET)
C INPUT ARGUMENTS:
C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING
C THIS ROUTINE.
C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE.
C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE
C CALLING THIS ROUTINE.
C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE)
C J INTEGER NUMBER OF FIELDS TO SKIP
C (=0 TO SEARCH FROM BEGINNING)
C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
C ( IF = -1, ACCEPT ANY DISCIPLINE)
C ( SEE CODE TABLE 0.0 )
C 0 - Meteorological products
C 1 - Hydrological products
C 2 - Land surface products
C 3 - Space products
C 10 - Oceanographic products
C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
C (=-9999 FOR WILDCARD)
C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE
C ( SEE COMMON CODE TABLE C-1 )
C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE
C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER
C ( SEE CODE TABLE 1.0 )
C 0 - Experimental
C 1 - Initial operational version number
C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER
C ( SEE CODE TABLE 1.1 )
C 0 - Local tables not used
C 1-254 - Number of local tables version used
C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
C 0 - Analysis
C 1 - Start of forecast
C 2 - Verifying time of forecast
C 3 - Observation time
C JIDS(6) = YEAR ( 4 DIGITS )
C JIDS(7) = MONTH
C JIDS(8) = DAY
C JIDS(9) = HOUR
C JIDS(10) = MINUTE
C JIDS(11) = SECOND
C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA
C ( SEE CODE TABLE 1.3 )
C 0 - Operational products
C 1 - Operational test products
C 2 - Research products
C 3 - Re-analysis products
C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
C 0 - Analysis products
C 1 - Forecast products
C 2 - Analysis and forecast products
C 3 - Control forecast products
C 4 - Perturbed forecast products
C 5 - Control and perturbed forecast products
C 6 - Processed satellite observations
C 7 - Processed radar observations
C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
C ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY )
C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
C (=-9999 FOR WILDCARD)
C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
C ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY )
C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
C (=-9999 FOR WILDCARD)
C EXTRACT LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2
C MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE
C GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD.
C .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED
C FIELD.
C .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE
C REQUESTED FIELD.
C
C OUTPUT ARGUMENTS:
C K INTEGER FIELD NUMBER RETURNED.
C GRIBM RETURNED GRIB MESSAGE.
C LENG LENGTH OF RETURNED GRIB MESSAGE IN BYTES.
C IRET INTEGER RETURN CODE
C 0 ALL OK
C 96 ERROR READING INDEX FILE
C 97 ERROR READING GRIB FILE
C 99 REQUEST NOT FOUND
C
C SUBPROGRAMS CALLED:
C GETG2I READ INDEX FILE
C GETG2IR READ INDEX BUFFER FROM GRIB FILE
C GETGB2S SEARCH INDEX RECORDS
C GETGB2RP READ A PACKED GRIB RECORD
C GF_FREE FREES MEMORY USED BY GFLD ( SEE REMARKS )
C
C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED.
C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
C
C Note that derived type gribfield contains pointers to many
C arrays of data. The memory for these arrays is allocated
C when the values in the arrays are set, to help minimize
C problems with array overloading. Because of this users
C are encouraged to free up this memory, when it is no longer
C needed, by an explicit call to subroutine gf_free.
C ( i.e. CALL GF_FREE(GFLD) )
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C
C$$$
USE GRIB_MOD
INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN
INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*)
LOGICAL,INTENT(IN) :: EXTRACT
INTEGER,INTENT(OUT) :: K,IRET,LENG
CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
TYPE(GRIBFIELD) :: GFLD
CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
PARAMETER(MSK1=32000,MSK2=4000)
SAVE CBUF,NLEN,NNUM
DATA LUX/0/
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C DECLARE INTERFACES (REQUIRED FOR CBUF POINTER)
INTERFACE
SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET)
CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
INTEGER,INTENT(IN) :: LUGI
INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET
END SUBROUTINE GETG2I
SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,
& NMESS,IRET)
CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
END SUBROUTINE GETG2IR
SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
INTEGER,INTENT(IN) :: LUGB
CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
LOGICAL,INTENT(IN) :: EXTRACT
INTEGER,INTENT(OUT) :: LENG,IRET
CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
END SUBROUTINE GETGB2RP
END INTERFACE
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
IRGI=0
IF(LUGI.GT.0.AND.LUGI.NE.LUX) THEN
CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRGI)
LUX=LUGI
ELSEIF(LUGI.LE.0.AND.LUGB.NE.LUX) THEN
MSKP=0
CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,CBUF,NLEN,NNUM,NMESS,IRGI)
LUX=LUGB
ENDIF
IF(IRGI.GT.1) THEN
IRET=96
LUX=0
RETURN
ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C SEARCH INDEX BUFFER
CALL GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT,
& JK,GFLD,LPOS,IRGS)
IF(IRGS.NE.0) THEN
IRET=99
CALL GF_FREE(GFLD)
RETURN
ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C EXTRACT GRIB MESSAGE FROM FILE
CALL GETGB2RP(LUGB,CBUF(LPOS:),EXTRACT,GRIBM,LENG,IRET)
! IF ( EXTRACT ) THEN
! PRINT *,'NOT SUPPOSED TO BE HERE.'
! ELSE
! IPOS=(LPOS+3)*8
! CALL GBYTE(CBUF,ISKIP,IPOS,32) ! BYTES TO SKIP IN FILE
! IPOS=IPOS+(32*8)
! CALL GBYTE(CBUF,LENG,IPOS,32) ! LENGTH OF GRIB MESSAGE
! IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
! CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM)
! IF ( LENG .NE. LREAD ) THEN
! IRET=97
! CALL GF_FREE(GFLD)
! RETURN
! ENDIF
! ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
K=JK
CALL GF_FREE(GFLD)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
RETURN
END