ixgb2.F90

Go to the documentation of this file.

 
 
SUBROUTINE ixgb2(LUGB, LSKIP, LGRIB, CBUF, NUMFLD, MLEN, IRET)
  USE re_alloc              ! NEEDED FOR SUBROUTINE REALLOC
  implicit none
 
  CHARACTER(LEN = 1), POINTER, DIMENSION(:) :: CBUF
  CHARACTER CVER, CDISC
  CHARACTER(LEN = 4) :: CTEMP
  INTEGER LOCLUS, LOCGDS, LENGDS, LOCBMS
  integer :: indbmp, numsec, next, newsize, mova2i, mbuf, lindex
  integer :: linmax, ixskp
  integer :: mxspd, mxskp, mxsgd, mxsdr, mxsbm, mxlus
  integer :: mxlen, mxds, mxfld, mxbms
  integer :: init, ixlus, lugb, lskip, lgrib, numfld, mlen, iret
  integer :: ixsgd, ibread, ibskip, ilndrs, ilnpds, istat, ixds
  integer :: ixspd, ixfld, ixids, ixlen, ixsbm, ixsdr
  integer :: lbread, lensec, lensec1
  parameter(linmax = 5000, init = 50000, next = 10000)
  parameter(ixskp = 4, ixlus = 8, ixsgd = 12, ixspd = 16, ixsdr = 20, ixsbm = 24, &
       ixds = 28, ixlen = 36, ixfld = 42, ixids = 44)
  parameter(mxskp = 4, mxlus = 4, mxsgd = 4, mxspd = 4, mxsdr = 4, mxsbm = 4, &
       mxds = 4, mxlen = 4, mxfld = 2, mxbms = 6)
  CHARACTER CBREAD(LINMAX), CINDEX(LINMAX)
  CHARACTER CIDS(LINMAX), CGDS(LINMAX)
 
  loclus = 0
  iret = 0
  mlen = 0
  numfld = 0
  NULLIFY(cbuf)
  mbuf = init
  ALLOCATE(cbuf(mbuf), stat = istat)    ! ALLOCATE INITIAL SPACE FOR CBUF
  IF (istat .NE. 0) THEN
     iret = 1
     RETURN
  ENDIF
 
  ! Read sections 0 and 1 for versin number and discipline.
  ibread = min(lgrib, linmax)
  CALL baread(lugb, lskip, ibread, lbread, cbread)
  IF(lbread .NE. ibread) THEN
     iret = 2
     RETURN
  ENDIF
  IF(cbread(8) .NE. char(2)) THEN          !  NOT GRIB EDITION 2
     iret = 3
     RETURN
  ENDIF
  cver = cbread(8)
  cdisc = cbread(7)
  CALL g2_gbytec(cbread, lensec1, 16 * 8, 4 * 8)
  lensec1 = min(lensec1, ibread)
  cids(1:lensec1) = cbread(17:16 + lensec1)
  ibskip = lskip + 16 + lensec1
 
  ! Loop through remaining sections creating an index for each field.
  ibread = max(5, mxbms)
  DO
     CALL baread(lugb, ibskip, ibread, lbread, cbread)
     ctemp = cbread(1)//cbread(2)//cbread(3)//cbread(4)
     IF (ctemp .EQ. '7777') RETURN        ! END OF MESSAGE FOUND
     IF(lbread .NE. ibread) THEN
        iret = 2
        RETURN
     ENDIF
     CALL g2_gbytec(cbread, lensec, 0 * 8, 4 * 8)
     CALL g2_gbytec(cbread, numsec, 4 * 8, 1 * 8)
 
     IF (numsec .EQ. 2) THEN                 ! SAVE LOCAL USE LOCATION
        loclus = ibskip-lskip
     ELSEIF (numsec .EQ. 3) THEN                 ! SAVE GDS INFO
        lengds = lensec
        cgds = char(0)
        CALL baread(lugb, ibskip, lengds, lbread, cgds)
        IF (lbread .NE. lengds) THEN
           iret = 2
           RETURN
        ENDIF
        locgds = ibskip-lskip
     ELSEIF (numsec .EQ. 4) THEN                 ! FOUND PDS
        cindex = char(0)
        CALL g2_sbytec(cindex, lskip, 8 * ixskp, 8 * mxskp)    ! BYTES TO SKIP
        CALL g2_sbytec(cindex, loclus, 8 * ixlus, 8 * mxlus)   ! LOCATION OF LOCAL USE
        CALL g2_sbytec(cindex, locgds, 8 * ixsgd, 8 * mxsgd)   ! LOCATION OF GDS
        CALL g2_sbytec(cindex, ibskip-lskip, 8 * ixspd, 8 * mxspd)  ! LOCATION OF PDS
        CALL g2_sbytec(cindex, lgrib, 8 * ixlen, 8 * mxlen)    ! LEN OF GRIB2
        cindex(41) = cver
        cindex(42) = cdisc
        CALL g2_sbytec(cindex, numfld + 1, 8 * ixfld, 8 * mxfld)   ! FIELD NUM
        cindex(ixids + 1:ixids + lensec1) = cids(1:lensec1)
        lindex = ixids + lensec1
        cindex(lindex + 1:lindex + lengds) = cgds(1:lengds)
        lindex = lindex + lengds
        ilnpds = lensec
        CALL baread(lugb, ibskip, ilnpds, lbread, cindex(lindex + 1))
        IF (lbread .NE. ilnpds) THEN
           iret = 2
           RETURN
        ENDIF
        lindex = lindex + ilnpds
     ELSEIF (numsec .EQ. 5) THEN                 ! FOUND DRS
        CALL g2_sbytec(cindex, ibskip-lskip, 8 * ixsdr, 8 * mxsdr)  ! LOCATION OF DRS
        ilndrs = lensec
        CALL baread(lugb, ibskip, ilndrs, lbread, cindex(lindex + 1))
        IF (lbread .NE. ilndrs) THEN
           iret = 2
           RETURN
        ENDIF
        lindex = lindex + ilndrs
     ELSEIF (numsec .EQ. 6) THEN                 ! FOUND BMS
        indbmp = mova2i(cbread(6))
        IF (indbmp.LT.254) THEN
           locbms = ibskip-lskip
           CALL g2_sbytec(cindex, locbms, 8 * ixsbm, 8 * mxsbm)  ! LOC. OF BMS
        ELSEIF (indbmp.EQ.254) THEN
           CALL g2_sbytec(cindex, locbms, 8 * ixsbm, 8 * mxsbm)  ! LOC. OF BMS
        ELSEIF (indbmp.EQ.255) THEN
           CALL g2_sbytec(cindex, ibskip-lskip, 8 * ixsbm, 8 * mxsbm)  ! LOC. OF BMS
        ENDIF
        cindex(lindex + 1:lindex + mxbms) = cbread(1:mxbms)
        lindex = lindex + mxbms
        CALL g2_sbytec(cindex, lindex, 0, 8 * 4)    ! NUM BYTES IN INDEX RECORD
     ELSEIF (numsec .EQ. 7) THEN                 ! FOUND DATA SECTION
        CALL g2_sbytec(cindex, ibskip-lskip, 8 * ixds, 8 * mxds)   ! LOC. OF DATA SEC.
        numfld = numfld + 1
        IF ((lindex + mlen) .GT. mbuf) THEN ! ALLOCATE MORE SPACE IF NECESSARY
           newsize = max(mbuf + next, mbuf + lindex)
           CALL realloc(cbuf, mlen, newsize, istat)
           IF (istat .NE. 0) THEN
              numfld = numfld-1
              iret = 4
              RETURN
           ENDIF
           mbuf = newsize
        ENDIF
        cbuf(mlen + 1:mlen + lindex) = cindex(1:lindex)
        mlen = mlen + lindex
     ELSE                           ! UNRECOGNIZED SECTION
        iret = 5
        RETURN
     ENDIF
     ibskip = ibskip + lensec
  ENDDO
END SUBROUTINE ixgb2