getg2ir.F90

Go to the documentation of this file.

 
 
SUBROUTINE getg2ir(LUGB, MSK1, MSK2, MNUM, CBUF, NLEN, NNUM, NMESS, IRET)
  USE re_alloc              ! NEEDED FOR SUBROUTINE REALLOC
  implicit none
 
  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
  integer :: nbytes, newsize, next, numfld, m, mbuf, lskip, lgrib
  integer :: istat, iseek, init, iret1
  parameter(init = 50000, next = 10000)
 
  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
 
  ! Initialize.
  iret = 0
  NULLIFY(cbuf)
  mbuf = init
  ALLOCATE(cbuf(mbuf), stat = istat)    ! Allocate initial space for cbuf.
  IF (istat .NE. 0) THEN
     iret = 2
     RETURN
  ENDIF
 
  ! 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
 
  ! Get index records for every grib message found.
  nlen = 0
  nnum = 0
  nmess = mnum
  DO WHILE(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
           iret = 3
           RETURN
        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
END SUBROUTINE getg2ir