external/io_grib2/g2lib/gf_unpack5.F

   1       subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
   2      &                   mapdrslen,ierr)
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !                .      .    .                                       .
   5 ! SUBPROGRAM:    gf_unpack5
   6 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
   7 !
   8 ! ABSTRACT: This subroutine unpacks Section 5 (Data Representation 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_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl,
  18 !                        mapdrslen,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 5.
  23 !
  24 !   OUTPUT ARGUMENT LIST:
  25 !     iofst    - Bit offset at the end of Section 5, returned.
  26 !     ndpts    - Number of data points unpacked and returned.
  27 !     idrsnum  - Data Representation Template Number ( see Code Table 5.0)
  28 !     idrstmpl - Pointer to an integer array containing the data values for
  29 !                the specified Data Representation
  30 !                Template ( N=idrsnum ).  Each element of this integer
  31 !                array contains an entry (in the order specified) of Data
  32 !                Representation Template 5.N
  33 !     mapdrslen- Number of elements in idrstmpl().  i.e. number of entries
  34 !                in Data Representation Template 5.N  ( N=idrsnum ).
  35 !     ierr     - Error return code.
  36 !                0 = no error
  37 !                6 = memory allocation error
  38 !                7 = "GRIB" message contains an undefined Data
  39 !                    Representation Template.
  40 !
  41 ! REMARKS: None
  42 !
  43 ! ATTRIBUTES:
  44 !   LANGUAGE: Fortran 90
  45 !   MACHINE:  IBM SP
  46 !
  47 !$$$
  48
  49       use drstemplates
  50       use re_alloc        !  needed for subroutine realloc
  51
  52       character(len=1),intent(in) :: cgrib(lcgrib)
  53       integer,intent(in) :: lcgrib
  54       integer,intent(inout) :: iofst
  55       integer,intent(out) :: ndpts,idrsnum
  56       integer,pointer,dimension(:) :: idrstmpl
  57       integer,intent(out) :: ierr
  58
  59       integer,allocatable :: mapdrs(:)
  60       integer :: mapdrslen
  61       logical needext
  62
  63       ierr=0
  64       nullify(idrstmpl)
  65
  66       call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
  67       iofst=iofst+32
  68       iofst=iofst+8     ! skip section number
  69       allocate(mapdrs(lensec))
  70
  71       call g2lib_gbyte(cgrib,ndpts,iofst,32)    ! Get num of data points
  72       iofst=iofst+32
  73       call g2lib_gbyte(cgrib,idrsnum,iofst,16)     ! Get Data Rep Template Num.
  74       iofst=iofst+16
  75       !   Gen Data Representation Template
  76       call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret)
  77       if (iret.ne.0) then
  78         ierr=7
  79         if( allocated(mapdrs) ) deallocate(mapdrs)
  80         return
  81       endif
  82       !
  83       !   Unpack each value into array ipdstmpl from the
  84       !   the appropriate number of octets, which are specified in
  85       !   corresponding entries in array mappds.
  86       !
  87       istat=0
  88       if (mapdrslen.gt.0) allocate(idrstmpl(mapdrslen),stat=istat)
  89       if (istat.ne.0) then
  90          ierr=6
  91          nullify(idrstmpl)
  92          if( allocated(mapdrs) ) deallocate(mapdrs)
  93          return
  94       endif
  95       do i=1,mapdrslen
  96         nbits=iabs(mapdrs(i))*8
  97         if ( mapdrs(i).ge.0 ) then
  98           call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
  99         else
 100           call g2lib_gbyte(cgrib,isign,iofst,1)
 101           call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
 102           if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
 103         endif
 104         iofst=iofst+nbits
 105       enddo
 106       !
 107       !   Check to see if the Data Representation Template needs to be
 108       !   extended.
 109       !   The number of values in a specific template may vary
 110       !   depending on data specified in the "static" part of the
 111       !   template.
 112       !
 113       if ( needext ) then
 114         call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs)
 115         call realloc(idrstmpl,mapdrslen,newmapdrslen,istat)
 116         !   Unpack the rest of the Data Representation Template
 117         do i=mapdrslen+1,newmapdrslen
 118           nbits=iabs(mapdrs(i))*8
 119           if ( mapdrs(i).ge.0 ) then
 120             call g2lib_gbyte(cgrib,idrstmpl(i),iofst,nbits)
 121           else
 122             call g2lib_gbyte(cgrib,isign,iofst,1)
 123             call g2lib_gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1)
 124             if (isign.eq.1) idrstmpl(i)=-idrstmpl(i)
 125           endif
 126           iofst=iofst+nbits
 127         enddo
 128         mapdrslen=newmapdrslen
 129       endif
 130       if( allocated(mapdrs) ) deallocate(mapdrs)
 131
 132       return    ! End of Section 5 processing
 133       end
 134