source: trunk/WRF.COMMON/WRFV2/external/io_grib2/g2lib/getg2ir.F

C-----------------------------------------------------------------------
      SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: GETG2IR        CREATES AN INDEX OF A GRIB2 FILE
C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2002-01-02
C
C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS.
C   THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT:
C       BYTE 001 - 004: LENGTH OF INDEX RECORD
C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
C       BYTE 042 - 042: MESSAGE DISCIPLINE
C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
C
C PROGRAM HISTORY LOG:
C   95-10-31  IREDELL
C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
C 2002-01-02  GILBERT   MODIFIED FROM GETGIR TO CREATE GRIB2 INDEXES
C
C USAGE:    CALL GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
C   INPUT ARGUMENTS:
C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB FILE
C     MSK1         INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE
C     MSK2         INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES
C     MNUM         INTEGER NUMBER OF GRIB MESSAGES TO SKIP (USUALLY 0)
C   OUTPUT ARGUMENTS:
C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
C     NLEN         INTEGER TOTAL LENGTH OF INDEX RECORD BUFFER IN BYTES
C     NNUM         INTEGER NUMBER OF INDEX RECORDS
C                  (=0 IF NO GRIB MESSAGES ARE FOUND)
C     NMESS        LAST GRIB MESSAGE IN FILE SUCCESSFULLY PROCESSED
C     IRET         INTEGER RETURN CODE
C                    0      ALL OK
C                    1      NOT ENOUGH MEMORY AVAILABLE TO HOLD FULL INDEX 
C                           BUFFER
C                    2      NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER
C
C SUBPROGRAMS CALLED:
C   SKGB           SEEK NEXT GRIB MESSAGE
C   IXGB2          MAKE INDEX RECORD
C
C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      USE RE_ALLOC          ! NEEDED FOR SUBROUTINE REALLOC
      PARAMETER(INIT=50000,NEXT=10000)
      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
      INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
      INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUFTMP
      INTERFACE      ! REQUIRED FOR CBUF POINTER
         SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
           INTEGER,INTENT(IN) :: LUGB,LSKIP,LGRIB
           CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
           INTEGER,INTENT(OUT) :: NUMFLD,MLEN,IRET
         END SUBROUTINE IXGB2
      END INTERFACE
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  INITIALIZE
      IRET=0
      IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
      MBUF=INIT
      ALLOCATE(CBUF(MBUF),STAT=ISTAT)    ! ALLOCATE INITIAL SPACE FOR CBUF
      IF (ISTAT.NE.0) THEN
         IRET=2
         RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SEARCH FOR FIRST GRIB MESSAGE
      ISEEK=0
      CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB)
      DO M=1,MNUM
        IF(LGRIB.GT.0) THEN
          ISEEK=LSKIP+LGRIB
          CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  GET INDEX RECORDS FOR EVERY GRIB MESSAGE FOUND
      NLEN=0
      NNUM=0
      NMESS=MNUM
      DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0)
        CALL IXGB2(LUGB,LSKIP,LGRIB,CBUFTMP,NUMFLD,NBYTES,IRET1)
        IF (IRET1.NE.0) PRINT *,' SAGT ',NUMFLD,NBYTES,IRET1
        IF((NBYTES+NLEN).GT.MBUF) THEN             ! ALLOCATE MORE SPACE, IF
                                                   ! NECESSARY
           NEWSIZE=MAX(MBUF+NEXT,MBUF+NBYTES)
           CALL REALLOC(CBUF,NLEN,NEWSIZE,ISTAT)
           IF ( ISTAT .NE. 0 ) THEN
              IRET=1
              RETURN
           ENDIF
           MBUF=NEWSIZE
        ENDIF
        !
        !  IF INDEX RECORDS WERE RETURNED IN CBUFTMP FROM IXGB2,
        !  COPY CBUFTMP INTO CBUF, THEN DEALLOCATE CBUFTMP WHEN DONE
        !
        IF ( ASSOCIATED(CBUFTMP) ) THEN
           CBUF(NLEN+1:NLEN+NBYTES)=CBUFTMP(1:NBYTES)
           DEALLOCATE(CBUFTMP,STAT=ISTAT)
           IF (ISTAT.NE.0) THEN
             PRINT *,' deallocating cbuftmp ... ',istat
             stop 99
           ENDIF
           NULLIFY(CBUFTMP)
           NNUM=NNUM+NUMFLD
           NLEN=NLEN+NBYTES
           NMESS=NMESS+1
        ENDIF
        !      LOOK FOR NEXT GRIB MESSAGE
        ISEEK=LSKIP+LGRIB
        CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END