getgb2s.F90

Go to the documentation of this file.

 
 
SUBROUTINE getgb2s(CBUF, NLEN, NNUM, J, JDISC, JIDS, JPDTN, JPDT, JGDTN, &
     JGDT, K, GFLD, LPOS, IRET)
  USE grib_mod
  implicit none
 
  CHARACTER(LEN = 1), INTENT(IN) :: CBUF(NLEN)
  INTEGER, INTENT(IN) :: NLEN, NNUM, J, JDISC, JPDTN, JGDTN
  INTEGER, DIMENSION(:) :: JIDS(*), JPDT(*), JGDT(*)
  INTEGER, INTENT(OUT) :: K, LPOS, IRET
  TYPE(gribfield), INTENT(OUT) :: GFLD
 
  INTEGER :: KGDS(5)
  LOGICAL :: MATCH1, MATCH3, MATCH4
  integer :: i, icnd, inlen, iof, ipos, jpos, lsec1, lsec3, lsec4, lsec5, numgdt, numpdt
 
  interface
     subroutine gf_unpack1(cgrib, lcgrib, iofst, ids, idslen, ierr)
       character(len = 1), intent(in) :: cgrib(lcgrib)
       integer, intent(in) :: lcgrib
       integer, intent(inout) :: iofst
       integer, pointer, dimension(:) :: ids
       integer, intent(out) :: ierr, idslen
     end subroutine gf_unpack1
     subroutine gf_unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, &
          mapgridlen, ideflist, idefnum, ierr)
       character(len = 1), intent(in) :: cgrib(lcgrib)
       integer, intent(in) :: lcgrib
       integer, intent(inout) :: iofst
       integer, pointer, dimension(:) :: igdstmpl, ideflist
       integer, intent(out) :: igds(5)
       integer, intent(out) :: ierr, idefnum
     end subroutine gf_unpack3
     subroutine gf_unpack4(cgrib, lcgrib, iofst, ipdsnum, ipdstmpl, &
          mappdslen, coordlist, numcoord, ierr)
       character(len = 1), intent(in) :: cgrib(lcgrib)
       integer, intent(in) :: lcgrib
       integer, intent(inout) :: iofst
       real, pointer, dimension(:) :: coordlist
       integer, pointer, dimension(:) :: ipdstmpl
       integer, intent(out) :: ipdsnum
       integer, intent(out) :: ierr, numcoord
     end subroutine gf_unpack4
     subroutine gf_unpack5(cgrib, lcgrib, iofst, ndpts, idrsnum, &
          idrstmpl, mapdrslen, ierr)
       character(len = 1), intent(in) :: cgrib(lcgrib)
       integer, intent(in) :: lcgrib
       integer, intent(inout) :: iofst
       integer, intent(out) :: ndpts, idrsnum
       integer, pointer, dimension(:) :: idrstmpl
       integer, intent(out) :: ierr
     end subroutine gf_unpack5
  end interface
 
  !     INITIALIZE
  k = 0
  lpos = 0
  iret = 1
  ipos = 0
  nullify(gfld%idsect, gfld%local)
  nullify(gfld%list_opt, gfld%igdtmpl, gfld%ipdtmpl)
  nullify(gfld%coord_list, gfld%idrtmpl, gfld%bmap, gfld%fld)
 
  !     SEARCH FOR REQUEST
  DO WHILE(iret.NE.0 .and. k.LT.nnum)
     k = k + 1
     CALL g2_gbytec(cbuf, inlen, ipos * 8, 4 * 8)    ! GET LENGTH OF CURRENT
     ! INDEX RECORD
     IF (k.LE.j) THEN           ! SKIP THIS INDEX
        ipos = ipos + inlen
        cycle
     ENDIF
 
     !     CHECK IF GRIB2 DISCIPLINE IS A MATCH
     CALL g2_gbytec(cbuf, gfld%DISCIPLINE, (ipos + 41)*8, 1*8)
     IF ((jdisc.NE.-1) .and. (jdisc.NE.gfld%DISCIPLINE)) THEN
        ipos = ipos + inlen
        cycle
     ENDIF
 
     !     CHECK IF IDENTIFICATION SECTION IS A MATCH
     match1 = .false.
     CALL g2_gbytec(cbuf, lsec1, (ipos + 44) * 8, 4 * 8)  ! GET LENGTH OF IDS 
     iof = 0
     CALL gf_unpack1(cbuf(ipos + 45), lsec1, iof, gfld%IDSECT, gfld%IDSECTLEN, icnd)
     IF (icnd .eq. 0) THEN
        match1 = .true.
        DO i = 1, gfld%IDSECTLEN
           IF ((jids(i).NE.-9999) .and.  (jids(i).NE.gfld%IDSECT(i))) THEN
              match1 = .false.
              EXIT
           ENDIF
        ENDDO
     ENDIF
     IF (.NOT. match1) THEN
        DEALLOCATE(gfld%IDSECT)
        ipos = ipos + inlen
        cycle
     ENDIF
 
     !     CHECK IF GRID DEFINITION TEMPLATE IS A MATCH
     jpos = ipos + 44 + lsec1
     match3 = .false.
     CALL g2_gbytec(cbuf, lsec3, jpos * 8, 4 * 8)  ! GET LENGTH OF GDS 
     IF (jgdtn .eq. -1) THEN
        match3 = .true.
     ELSE
        CALL g2_gbytec(cbuf, numgdt, (jpos + 12) * 8, 2 * 8)  ! GET GDT TEMPLATE NO.
        IF (jgdtn .eq. numgdt) THEN
           iof = 0
           CALL gf_unpack3(cbuf(jpos + 1), lsec3, iof, kgds, gfld%IGDTMPL, &
                gfld%IGDTLEN, gfld%LIST_OPT, gfld%NUM_OPT, icnd)
           IF (icnd .eq. 0) THEN
              match3 = .true.
              DO i = 1, gfld%IGDTLEN
                 IF ((jgdt(i).NE.-9999) .and.  (jgdt(i).NE.gfld%IGDTMPL(i))) THEN
                    match3 = .false.
                    EXIT
                 ENDIF
              ENDDO
           ENDIF
        ENDIF
     ENDIF
     IF (.NOT. match3) THEN
        IF (ASSOCIATED(gfld%IDSECT)) DEALLOCATE(gfld%IDSECT)
        IF (ASSOCIATED(gfld%IGDTMPL)) DEALLOCATE(gfld%IGDTMPL)
        IF (ASSOCIATED(gfld%LIST_OPT)) DEALLOCATE(gfld%LIST_OPT)
        ipos = ipos + inlen
        cycle
     ELSE
        gfld%GRIDDEF = kgds(1)
        gfld%NGRDPTS = kgds(2)
        gfld%NUMOCT_OPT = kgds(3)
        gfld%INTERP_OPT = kgds(4)
        gfld%IGDTNUM = kgds(5)
     ENDIF
 
     !     CHECK IF PRODUCT DEFINITION TEMPLATE IS A MATCH
     jpos = jpos + lsec3
     match4 = .false.
     CALL g2_gbytec(cbuf, lsec4, jpos * 8, 4 * 8)  ! GET LENGTH OF PDS 
     IF (jpdtn .eq. -1) THEN
        match4 = .true.
     ELSE
        CALL g2_gbytec(cbuf, numpdt, (jpos + 7) * 8, 2 * 8)  ! GET PDT TEMPLATE NO.
        IF (jpdtn .eq. numpdt) THEN
           iof = 0
           CALL gf_unpack4(cbuf(jpos + 1), lsec4, iof, gfld%IPDTNUM, &
                gfld%IPDTMPL, gfld%IPDTLEN, gfld%COORD_LIST, gfld%NUM_COORD, icnd)
           IF (icnd .eq. 0) THEN
              match4 = .true.
              DO i = 1, gfld%IPDTLEN
                 IF ((jpdt(i).NE.-9999) .and.  (jpdt(i).NE.gfld%IPDTMPL(i))) THEN
                    match4 = .false.
                    EXIT
                 ENDIF
              ENDDO
           ENDIF
        ENDIF
     ENDIF
     IF (.NOT. match4) THEN
        IF (ASSOCIATED(gfld%IDSECT)) DEALLOCATE(gfld%IDSECT)
        IF (ASSOCIATED(gfld%IPDTMPL)) DEALLOCATE(gfld%IPDTMPL)
        IF (ASSOCIATED(gfld%COORD_LIST)) DEALLOCATE(gfld%COORD_LIST)
     ENDIF
 
     !     IF REQUEST IS FOUND
     !     SET VALUES FOR DERIVED TYPE GFLD AND RETURN
     IF(match1 .and. match3 .and. match4) THEN
        lpos = ipos + 1
        CALL g2_gbytec(cbuf, gfld%VERSION, (ipos + 40) * 8, 1 * 8)
        CALL g2_gbytec(cbuf, gfld%IFLDNUM, (ipos + 42) * 8, 2 * 8)
        gfld%UNPACKED = .false.
        jpos = ipos + 44 + lsec1
        IF (jgdtn.EQ.-1) THEN     ! UNPACK GDS, IF NOT DONE BEFORE
           iof = 0
           CALL gf_unpack3(cbuf(jpos + 1), lsec3, iof, kgds, gfld%IGDTMPL, &
                gfld%IGDTLEN, gfld%LIST_OPT, gfld%NUM_OPT, icnd)
           gfld%GRIDDEF = kgds(1)
           gfld%NGRDPTS = kgds(2)
           gfld%NUMOCT_OPT = kgds(3)
           gfld%INTERP_OPT = kgds(4)
           gfld%IGDTNUM = kgds(5)
        ENDIF
        jpos = jpos + lsec3
        IF (jpdtn.EQ.-1 ) THEN     ! UNPACK PDS, IF NOT DONE BEFORE
           iof = 0
           CALL gf_unpack4(cbuf(jpos + 1), lsec4, iof, gfld%IPDTNUM, &
                gfld%IPDTMPL, gfld%IPDTLEN, gfld%COORD_LIST, gfld%NUM_COORD, icnd)
        ENDIF
        jpos = jpos + lsec4
        CALL g2_gbytec(cbuf, lsec5, jpos * 8, 4 * 8)  ! GET LENGTH OF DRS 
        iof = 0
        CALL gf_unpack5(cbuf(jpos + 1), lsec5, iof, gfld%NDPTS, &
             gfld%IDRTNUM, gfld%IDRTMPL, gfld%IDRTLEN, icnd)
        jpos = jpos + lsec5
        CALL g2_gbytec(cbuf, gfld%IBMAP, (jpos + 5)*8, 1 * 8)  ! GET IBMAP
        iret = 0
     ELSE      ! PDT DID NOT MATCH
        ipos = ipos+inlen
     ENDIF
  ENDDO
END SUBROUTINE getgb2s