getg2ir.f

Go to the documentation of this file.

C>    @file
C>    @brief This subroutine read a GRIB file and return its index content.
C>    @author Mark Iredell @date 1995-10-31
C>
 
C>    This subroutine read a GRIB file and return its index content.
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>    - 1995-10-31 mark iredell
C>    - 1996-10-31 mark iredell augmented optional definitions to byte 320
C>    - 2002-01-02 stephen gilbert modified from getgir to create grib2 indexes
C>
C>    @param[in] lugb integer unit of the unblocked grib file
C>    @param[in] msk1 integer number of bytes to search for first message
C>    @param[in] msk2 integer number of bytes to search for other messages
C>    @param[in] mnum integer number of grib messages to skip (usually 0)
C>    output arguments:
C>    @param[out] cbuf character*1 pointer to a buffer that contains index
C>    records. users should free memory that cbuf points to, using
C>    deallocate(cbuf) when cbuf is no longer needed.
C>    @param[out] nlen integer total length of index record buffer in bytes
C>    @param[out] nnum integer number of index records, =0 if no grib
C>    messages are found)
C>    @param[out] nmess last grib message in file successfully processed
C>    @param[out] iret integer return code
C>    - 0 all ok
C>    - 1 not enough memory available to hold full index 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>    @note subprogram can be called from a multiprocessing environment.
C>    do not engage the same logical unit from more than one processor.
C>
C>    @author Mark Iredell @date 1995-10-31
C>
 
      SUBROUTINE getg2ir(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
 
      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