external/io_grib2/g2lib/gettemplates.F

   1       subroutine gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl,
   2      &                    igdslen,ideflist,idefnum,ipdsnum,ipdstmpl,
   3      &                    ipdslen,coordlist,numcoord,ierr)
   4 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   5 !                .      .    .                                       .
   6 ! SUBPROGRAM:    gettemplates
   7 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-26
   8 !
   9 ! ABSTRACT: This subroutine returns the Grid Definition, and
  10 !   Product Definition for a given data
  11 !   field.  Since there can be multiple data fields packed into a GRIB2
  12 !   message, the calling routine indicates which field is being requested
  13 !   with the ifldnum argument.
  14 !
  15 ! PROGRAM HISTORY LOG:
  16 ! 2000-05-26  Gilbert
  17 !
  18 ! USAGE:    CALL gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen,
  19 !    &                    ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen,
  20 !    &                    coordlist,numcoord,ierr)
  21 !   INPUT ARGUMENT LIST:
  22 !     cgrib    - Character array that contains the GRIB2 message
  23 !     lcgrib   - Length (in bytes) of GRIB message array cgrib.
  24 !     ifldnum  - Specifies which field in the GRIB2 message to return.
  25 !
  26 !   OUTPUT ARGUMENT LIST:
  27 !     igds     - Contains information read from the appropriate GRIB Grid
  28 !                Definition Section 3 for the field being returned.
  29 !                Must be dimensioned >= 5.
  30 !                igds(1)=Source of grid definition (see Code Table 3.0)
  31 !                igds(2)=Number of grid points in the defined grid.
  32 !                igds(3)=Number of octets needed for each
  33 !                            additional grid points definition.
  34 !                            Used to define number of
  35 !                            points in each row ( or column ) for
  36 !                            non-regular grids.
  37 !                            = 0, if using regular grid.
  38 !                igds(4)=Interpretation of list for optional points
  39 !                            definition.  (Code Table 3.11)
  40 !                igds(5)=Grid Definition Template Number (Code Table 3.1)
  41 !     igdstmpl - Contains the data values for 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 !                A safe dimension for this array can be obtained in advance
  46 !                from maxvals(2), which is returned from subroutine gribinfo.
  47 !     igdslen  - Number of elements in igdstmpl().  i.e. number of entries
  48 !                in Grid Defintion Template 3.NN  ( NN=igds(5) ).
  49 !     ideflist - (Used if igds(3) .ne. 0)  This array contains the
  50 !                number of grid points contained in each row ( or column ).
  51 !                (part of Section 3)
  52 !                A safe dimension for this array can be obtained in advance
  53 !                from maxvals(3), which is returned from subroutine gribinfo.
  54 !     idefnum  - (Used if igds(3) .ne. 0)  The number of entries
  55 !                in array ideflist.  i.e. number of rows ( or columns )
  56 !                for which optional grid points are defined.
  57 !     ipdsnum  - Product Definition Template Number ( see Code Table 4.0)
  58 !     ipdstmpl - Contains the data values for the specified Product Definition
  59 !                Template ( N=ipdsnum ).  Each element of this integer
  60 !                array contains an entry (in the order specified) of Product
  61 !                Defintion Template 4.N
  62 !                A safe dimension for this array can be obtained in advance
  63 !                from maxvals(4), which is returned from subroutine gribinfo.
  64 !     ipdslen  - Number of elements in ipdstmpl().  i.e. number of entries
  65 !                in Product Defintion Template 4.N  ( N=ipdsnum ).
  66 !     coordlist- Array containg floating point values intended to document
  67 !                the vertical discretisation associated to model data
  68 !                on hybrid coordinate vertical levels.  (part of Section 4)
  69 !                The dimension of this array can be obtained in advance
  70 !                from maxvals(5), which is returned from subroutine gribinfo.
  71 !     numcoord - number of values in array coordlist.
  72 !     ierr     - Error return code.
  73 !                0 = no error
  74 !                1 = Beginning characters "GRIB" not found.
  75 !                2 = GRIB message is not Edition 2.
  76 !                3 = The data field request number was not positive.
  77 !                4 = End string "7777" found, but not where expected.
  78 !                6 = GRIB message did not contain the requested number of
  79 !                    data fields.
  80 !                7 = End string "7777" not found at end of message.
  81 !               10 = Error unpacking Section 3.
  82 !               11 = Error unpacking Section 4.
  83 !
  84 ! REMARKS: Note that subroutine gribinfo can be used to first determine
  85 !          how many data fields exist in the given GRIB message.
  86 !
  87 ! ATTRIBUTES:
  88 !   LANGUAGE: Fortran 90
  89 !   MACHINE:  IBM SP
  90 !
  91 !$$$
  92
  93       character(len=1),intent(in) :: cgrib(lcgrib)
  94       integer,intent(in) :: lcgrib,ifldnum
  95       integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*)
  96       integer,intent(out) :: ipdsnum,ipdstmpl(*)
  97       integer,intent(out) :: idefnum,numcoord
  98       integer,intent(out) :: ierr
  99       real,intent(out) :: coordlist(*)
 100
 101       character(len=4),parameter :: grib='GRIB',c7777='7777'
 102       character(len=4) :: ctemp
 103       integer:: listsec0(2)
 104       integer iofst,ibeg,istart
 105       logical have3,have4
 106
 107       have3=.false.
 108       have4=.false.
 109       ierr=0
 110       numfld=0
 111 !
 112 !  Check for valid request number
 113 !
 114       if (ifldnum.le.0) then
 115         print *,'gettemplates: Request for field number must be ',
 116      &          'positive.'
 117         ierr=3
 118         return
 119       endif
 120 !
 121 !  Check for beginning of GRIB message in the first 100 bytes
 122 !
 123       istart=0
 124       do j=1,100
 125         ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3)
 126         if (ctemp.eq.grib ) then
 127           istart=j
 128           exit
 129         endif
 130       enddo
 131       if (istart.eq.0) then
 132         print *,'gettemplates:  Beginning characters GRIB not found.'
 133         ierr=1
 134         return
 135       endif
 136 !
 137 !  Unpack Section 0 - Indicator Section
 138 !
 139       iofst=8*(istart+5)
 140       call g2lib_gbyte(cgrib,listsec0(1),iofst,8)     ! Discipline
 141       iofst=iofst+8
 142       call g2lib_gbyte(cgrib,listsec0(2),iofst,8)     ! GRIB edition number
 143       iofst=iofst+8
 144       iofst=iofst+32
 145       call g2lib_gbyte(cgrib,lengrib,iofst,32)        ! Length of GRIB message
 146       iofst=iofst+32
 147       lensec0=16
 148       ipos=istart+lensec0
 149 !
 150 !  Currently handles only GRIB Edition 2.
 151 !
 152       if (listsec0(2).ne.2) then
 153         print *,'gettemplates: can only decode GRIB edition 2.'
 154         ierr=2
 155         return
 156       endif
 157 !
 158 !  Loop through the remaining sections keeping track of the
 159 !  length of each.  Also keep the latest Grid Definition Section info.
 160 !  Unpack the requested field number.
 161 !
 162       do
 163         !    Check to see if we are at end of GRIB message
 164         ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3)
 165         if (ctemp.eq.c7777 ) then
 166           ipos=ipos+4
 167           !    If end of GRIB message not where expected, issue error
 168           if (ipos.ne.(istart+lengrib)) then
 169             print *,'gettemplates: "7777" found, but not where ',
 170      &              'expected.'
 171             ierr=4
 172             return
 173           endif
 174           exit
 175         endif
 176         !     Get length of Section and Section number
 177         iofst=(ipos-1)*8
 178         call g2lib_gbyte(cgrib,lensec,iofst,32)        ! Get Length of Section
 179         iofst=iofst+32
 180         call g2lib_gbyte(cgrib,isecnum,iofst,8)         ! Get Section number
 181         iofst=iofst+8
 182         !print *,' lensec= ',lensec,'    secnum= ',isecnum
 183         !
 184         !   If found Section 3, unpack the GDS info using the
 185         !   appropriate template.  Save in case this is the latest
 186         !   grid before the requested field.
 187         !
 188         if (isecnum.eq.3) then
 189           iofst=iofst-40       ! reset offset to beginning of section
 190           call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen,
 191      &                 ideflist,idefnum,jerr)
 192           if (jerr.eq.0) then
 193             have3=.true.
 194           else
 195             ierr=10
 196             return
 197           endif
 198         endif
 199         !
 200         !   If found Section 4, check to see if this field is the
 201         !   one requested.
 202         !
 203         if (isecnum.eq.4) then
 204           numfld=numfld+1
 205           if (numfld.eq.ifldnum) then
 206             iofst=iofst-40       ! reset offset to beginning of section
 207             call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen,
 208      &                   coordlist,numcoord,jerr)
 209             if (jerr.eq.0) then
 210               have4=.true.
 211             else
 212               ierr=11
 213               return
 214             endif
 215           endif
 216         endif
 217         !
 218         !   Check to see if we read pass the end of the GRIB
 219         !   message and missed the terminator string '7777'.
 220         !
 221         ipos=ipos+lensec                 ! Update beginning of section pointer
 222         if (ipos.gt.(istart+lengrib)) then
 223           print *,'gettemplates: "7777"  not found at end of GRIB ',
 224      &            'message.'
 225           ierr=7
 226           return
 227         endif
 228
 229         if (have3.and.have4) return
 230
 231       enddo
 232
 233 !
 234 !  If exited from above loop, the end of the GRIB message was reached
 235 !  before the requested field was found.
 236 !
 237       print *,'gettemplates: GRIB message contained ',numlocal,
 238      &        ' different fields.'
 239       print *,'gettemplates: The request was for the ',ifldnum,
 240      &        ' field.'
 241       ierr=6
 242
 243       return
 244       end