external/io_grib2/g2lib/gf_unpack3.F

   1       subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
   2      &                   mapgridlen,ideflist,idefnum,ierr)
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !                .      .    .                                       .
   5 ! SUBPROGRAM:    gf_unpack3
   6 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
   7 !
   8 ! ABSTRACT: This subroutine unpacks Section 3 (Grid Definition Section)
   9 !   starting at octet 6 of that Section.
  10 !
  11 ! PROGRAM HISTORY LOG:
  12 ! 2000-05-26  Gilbert
  13 ! 2002-01-24  Gilbert  - Changed to dynamically allocate arrays
  14 !                        and to pass pointers to those arrays through
  15 !                        the argument list.
  16 !
  17 ! USAGE:    CALL gf_unpack3(cgrib,lcgrib,lensec,iofst,igds,igdstmpl,
  18 !    &                   mapgridlen,ideflist,idefnum,ierr)
  19 !   INPUT ARGUMENT LIST:
  20 !     cgrib    - Character array that contains the GRIB2 message
  21 !     lcgrib   - Length (in bytes) of GRIB message array cgrib.
  22 !     iofst    - Bit offset of the beginning of Section 3.
  23 !
  24 !   OUTPUT ARGUMENT LIST:
  25 !     iofst    - Bit offset at the end of Section 3, returned.
  26 !     igds     - Contains information read from the appropriate GRIB Grid
  27 !                Definition Section 3 for the field being returned.
  28 !                Must be dimensioned >= 5.
  29 !                igds(1)=Source of grid definition (see Code Table 3.0)
  30 !                igds(2)=Number of grid points in the defined grid.
  31 !                igds(3)=Number of octets needed for each
  32 !                            additional grid points definition.
  33 !                            Used to define number of
  34 !                            points in each row ( or column ) for
  35 !                            non-regular grids.
  36 !                            = 0, if using regular grid.
  37 !                igds(4)=Interpretation of list for optional points
  38 !                            definition.  (Code Table 3.11)
  39 !                igds(5)=Grid Definition Template Number (Code Table 3.1)
  40 !     igdstmpl - Pointer to integer array containing the data values for
  41 !                the specified Grid Definition
  42 !                Template ( NN=igds(5) ).  Each element of this integer
  43 !                array contains an entry (in the order specified) of Grid
  44 !                Defintion Template 3.NN
  45 !     mapgridlen- Number of elements in igdstmpl().  i.e. number of entries
  46 !                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
  47 !     ideflist - (Used if igds(3) .ne. 0)  Pointer to integer array containing
  48 !                the number of grid points contained in each row ( or column ).
  49 !                (part of Section 3)
  50 !     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
  51 !                in array ideflist.  i.e. number of rows ( or columns )
  52 !                for which optional grid points are defined.
  53 !     ierr     - Error return code.
  54 !                0 = no error
  55 !                5 = "GRIB" message contains an undefined Grid Definition
  56 !                    Template.
  57 !                6 = memory allocation error
  58 !
  59 ! REMARKS: Uses Fortran 90 module gridtemplates and module re_alloc.
  60 !
  61 ! ATTRIBUTES:
  62 !   LANGUAGE: Fortran 90
  63 !   MACHINE:  IBM SP
  64 !
  65 !$$$
  66
  67       use gridtemplates
  68       use re_alloc        !  needed for subroutine realloc
  69
  70       character(len=1),intent(in) :: cgrib(lcgrib)
  71       integer,intent(in) :: lcgrib
  72       integer,intent(inout) :: iofst
  73       integer,pointer,dimension(:) :: igdstmpl,ideflist
  74       integer,intent(out) :: igds(5)
  75       integer,intent(out) :: ierr,idefnum
  76
  77       integer,allocatable :: mapgrid(:)
  78       integer :: mapgridlen,ibyttem
  79       logical needext
  80
  81       ierr=0
  82       nullify(igdstmpl,ideflist)
  83
  84       call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
  85       iofst=iofst+32
  86       iofst=iofst+8     ! skip section number
  87
  88       call g2lib_gbyte(cgrib,igds(1),iofst,8)     ! Get source of Grid def.
  89       iofst=iofst+8
  90       call g2lib_gbyte(cgrib,igds(2),iofst,32)    ! Get number of grid pts.
  91       iofst=iofst+32
  92       call g2lib_gbyte(cgrib,igds(3),iofst,8)     ! Get num octets for opt. list
  93       iofst=iofst+8
  94       call g2lib_gbyte(cgrib,igds(4),iofst,8)     ! Get interpret. for opt. list
  95       iofst=iofst+8
  96       call g2lib_gbyte(cgrib,igds(5),iofst,16)    ! Get Grid Def Template num.
  97       iofst=iofst+16
  98 !      if (igds(1).eq.0) then
  99       if (igds(1).eq.0.OR.igds(1).eq.255) then  ! FOR ECMWF TEST ONLY
 100         allocate(mapgrid(lensec))
 101         !   Get Grid Definition Template
 102         call getgridtemplate(igds(5),mapgridlen,mapgrid,needext,
 103      &                       iret)
 104         if (iret.ne.0) then
 105           ierr=5
 106           if( allocated(mapgrid) ) deallocate(mapgrid)
 107           return
 108         endif
 109       else
 110 !        igdstmpl=-1
 111         mapgridlen=0
 112         needext=.false.
 113       endif
 114       !
 115       !   Unpack each value into array igdstmpl from the
 116       !   the appropriate number of octets, which are specified in
 117       !   corresponding entries in array mapgrid.
 118       !
 119       istat=0
 120       if (mapgridlen.gt.0) allocate(igdstmpl(mapgridlen),stat=istat)
 121       if (istat.ne.0) then
 122          ierr=6
 123          nullify(igdstmpl)
 124          if( allocated(mapgrid) ) deallocate(mapgrid)
 125          return
 126       endif
 127       ibyttem=0
 128       do i=1,mapgridlen
 129         nbits=iabs(mapgrid(i))*8
 130         if ( mapgrid(i).ge.0 ) then
 131           call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
 132         else
 133           call g2lib_gbyte(cgrib,isign,iofst,1)
 134           call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
 135           if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
 136         endif
 137         iofst=iofst+nbits
 138         ibyttem=ibyttem+iabs(mapgrid(i))
 139       enddo
 140       !
 141       !   Check to see if the Grid Definition Template needs to be
 142       !   extended.
 143       !   The number of values in a specific template may vary
 144       !   depending on data specified in the "static" part of the
 145       !   template.
 146       !
 147       if ( needext ) then
 148         call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid)
 149         !   Unpack the rest of the Grid Definition Template
 150         call realloc(igdstmpl,mapgridlen,newmapgridlen,istat)
 151         do i=mapgridlen+1,newmapgridlen
 152           nbits=iabs(mapgrid(i))*8
 153           if ( mapgrid(i).ge.0 ) then
 154             call g2lib_gbyte(cgrib,igdstmpl(i),iofst,nbits)
 155           else
 156             call g2lib_gbyte(cgrib,isign,iofst,1)
 157             call g2lib_gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1)
 158             if (isign.eq.1) igdstmpl(i)=-igdstmpl(i)
 159           endif
 160           iofst=iofst+nbits
 161           ibyttem=ibyttem+iabs(mapgrid(i))
 162         enddo
 163         mapgridlen=newmapgridlen
 164       endif
 165       if( allocated(mapgrid) ) deallocate(mapgrid)
 166       !
 167       !   Unpack optional list of numbers defining number of points
 168       !   in each row or column, if included.  This is used for non regular
 169       !   grids.
 170       !
 171       if ( igds(3).ne.0 ) then
 172          nbits=igds(3)*8
 173          idefnum=(lensec-14-ibyttem)/igds(3)
 174          istat=0
 175          if (idefnum.gt.0) allocate(ideflist(idefnum),stat=istat)
 176          if (istat.ne.0) then
 177             ierr=6
 178             nullify(ideflist)
 179             return
 180          endif
 181          call g2lib_gbytes(cgrib,ideflist,iofst,nbits,0,idefnum)
 182          iofst=iofst+(nbits*idefnum)
 183       else
 184          idefnum=0
 185          nullify(ideflist)
 186       endif
 187
 188       return    ! End of Section 3 processing
 189       end