gf_unpack3.F90

Go to the documentation of this file.

 
 
subroutine gf_unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, &
     mapgridlen, ideflist, idefnum, ierr)
 
  use gridtemplates
  use re_alloc              !  needed for subroutine realloc
  implicit none
 
  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
 
  integer, allocatable :: mapgrid(:)
  integer, intent(out) :: mapgridlen
  integer :: ibyttem
  logical needext
  integer :: lensec, istat, i, nbits, isign, newmapgridlen, iret
 
  ierr = 0
  nullify(igdstmpl, ideflist)
 
  call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section
  iofst = iofst + 32
  iofst = iofst + 8             ! skip section number
 
  call g2_gbytec(cgrib, igds(1), iofst, 8) ! Get source of Grid def.
  iofst = iofst + 8
  call g2_gbytec(cgrib, igds(2), iofst, 32) ! Get number of grid pts.
  iofst = iofst + 32
  call g2_gbytec(cgrib, igds(3), iofst, 8) ! Get num octets for opt. list
  iofst = iofst + 8
  call g2_gbytec(cgrib, igds(4), iofst, 8) ! Get interpret. for opt. list
  iofst = iofst + 8
  call g2_gbytec(cgrib, igds(5), iofst, 16) ! Get Grid Def Template num.
  iofst = iofst + 16
 
  if (igds(1) .eq. 0 .OR. igds(1) .eq. 255) then ! FOR ECMWF TEST ONLY
     allocate(mapgrid(lensec))
 
     !         Get Grid Definition Template
     call getgridtemplate(igds(5), mapgridlen, mapgrid, needext, iret)
     if (iret .ne. 0) then
        ierr = 5
        if (allocated(mapgrid)) deallocate(mapgrid)
        return
     endif
  else
     mapgridlen = 0
     needext = .false.
  endif
 
  !     Unpack each value into array igdstmpl from the the appropriate
  !     number of octets, which are specified in corresponding entries in
  !     array mapgrid.
  istat = 0
  if (mapgridlen .gt. 0) allocate(igdstmpl(mapgridlen), stat = istat)
  if (istat .ne. 0) then
     ierr = 6
     nullify(igdstmpl)
     if (allocated(mapgrid)) deallocate(mapgrid)
     return
  endif
  ibyttem = 0
  do i = 1, mapgridlen
     nbits = iabs(mapgrid(i)) * 8
     if (mapgrid(i) .ge. 0) then
        call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits)
     else
        call g2_gbytec(cgrib, isign, iofst, 1)
        call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits - 1)
        if (isign .eq. 1) igdstmpl(i) = -igdstmpl(i)
     endif
     iofst = iofst + nbits
     ibyttem = ibyttem + iabs(mapgrid(i))
  enddo
 
  !     Check to see if the Grid Definition Template needs to be extended.
  !     The number of values in a specific template may vary depending on
  !     data specified in the "static" part of the template.
  if (needext) then
     call extgridtemplate(igds(5), igdstmpl, newmapgridlen, &
          mapgrid)
 
     ! Unpack the rest of the Grid Definition Template.
     call realloc(igdstmpl, mapgridlen, newmapgridlen, istat)
     do i = mapgridlen + 1, newmapgridlen
        nbits = iabs(mapgrid(i)) * 8
        if (mapgrid(i) .ge. 0) then
           call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits)
        else
           call g2_gbytec(cgrib, isign, iofst, 1)
           call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits - 1)
           if (isign.eq.1) igdstmpl(i) = -igdstmpl(i)
        endif
        iofst = iofst + nbits
        ibyttem = ibyttem + iabs(mapgrid(i))
     enddo
     mapgridlen = newmapgridlen
  endif
  if (allocated(mapgrid)) deallocate(mapgrid)
 
  ! Unpack optional list of numbers defining number of points in each
  ! row or column, if included. This is used for non regular grids.
  if (igds(3) .ne. 0) then
     nbits = igds(3) * 8
     idefnum = (lensec - 14 - ibyttem) / igds(3)
     istat = 0
     if (idefnum .gt. 0) allocate(ideflist(idefnum), stat = istat)
     if (istat .ne. 0) then
        ierr = 6
        nullify(ideflist)
        return
     endif
     call g2_gbytesc(cgrib, ideflist, iofst, nbits, 0, idefnum)
     iofst = iofst + (nbits * idefnum)
  else
     idefnum = 0
     nullify(ideflist)
  endif
end subroutine gf_unpack3