hwrf-baseline-20120103-1354/ungrib/src/ngl/g2/putgb2.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE PUTGB2(LUGB,GFLD,IRET)
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM: PUTGB2         PACKS AND WRITES A GRIB2 MESSAGE
   6 C   PRGMMR: GILBERT          ORG: W/NP11     DATE: 2002-04-22
   7 C
   8 C ABSTRACT: PACKS A SINGLE FIELD INTO A GRIB2 MESSAGE
   9 C   AND WRITES OUT THAT MESSAGE TO THE FILE ASSOCIATED WITH UNIT LUGB.
  10 C   NOTE THAT FILE/UNIT LUGB SHOULD BE OPENED WOTH A CALL TO
  11 C   SUBROUTINE BAOPENW BEFORE THIS ROUTINE IS CALLED.
  12 C
  13 C   The information to be packed into the GRIB field
  14 C   is stored in a derived type variable, gfld.
  15 C   Gfld is of type gribfield, which is defined
  16 C   in module grib_mod, so users of this routine will need to include
  17 C   the line "USE GRIB_MOD" in their calling routine.  Each component of the
  18 C   gribfield type is described in the INPUT ARGUMENT LIST section below.
  19 C
  20 C PROGRAM HISTORY LOG:
  21 C 2002-04-22  GILBERT
  22 C 2005-02-28  GILBERT   - Changed dimension of array cgrib to be a multiple
  23 C                         of gfld%ngrdpts instead of gfld%ndpts.
  24 C 2009-03-10  VUONG     - Initialize variable coordlist
  25 C
  26 C USAGE:    CALL PUTGB2(LUGB,GFLD,IRET)
  27 C   INPUT ARGUMENTS:
  28 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
  29 C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENW BEFORE CALLING
  30 C                  THIS ROUTINE.
  31 C     gfld - derived type gribfield ( defined in module grib_mod )
  32 C            ( NOTE: See Remarks Section )
  33 C        gfld%version = GRIB edition number ( currently 2 )
  34 C        gfld%discipline = Message Discipline ( see Code Table 0.0 )
  35 C        gfld%idsect() = Contains the entries in the Identification
  36 C                        Section ( Section 1 )
  37 C                        This element is actually a pointer to an array
  38 C                        that holds the data.
  39 C            gfld%idsect(1)  = Identification of originating Centre
  40 C                                    ( see Common Code Table C-1 )
  41 C                             7 - US National Weather Service
  42 C            gfld%idsect(2)  = Identification of originating Sub-centre
  43 C            gfld%idsect(3)  = GRIB Master Tables Version Number
  44 C                                    ( see Code Table 1.0 )
  45 C                             0 - Experimental
  46 C                             1 - Initial operational version number
  47 C            gfld%idsect(4)  = GRIB Local Tables Version Number
  48 C                                    ( see Code Table 1.1 )
  49 C                             0     - Local tables not used
  50 C                             1-254 - Number of local tables version used
  51 C            gfld%idsect(5)  = Significance of Reference Time (Code Table 1.2)
  52 C                             0 - Analysis
  53 C                             1 - Start of forecast
  54 C                             2 - Verifying time of forecast
  55 C                             3 - Observation time
  56 C            gfld%idsect(6)  = Year ( 4 digits )
  57 C            gfld%idsect(7)  = Month
  58 C            gfld%idsect(8)  = Day
  59 C            gfld%idsect(9)  = Hour
  60 C            gfld%idsect(10)  = Minute
  61 C            gfld%idsect(11)  = Second
  62 C            gfld%idsect(12)  = Production status of processed data
  63 C                                    ( see Code Table 1.3 )
  64 C                              0 - Operational products
  65 C                              1 - Operational test products
  66 C                              2 - Research products
  67 C                              3 - Re-analysis products
  68 C            gfld%idsect(13)  = Type of processed data ( see Code Table 1.4 )
  69 C                              0  - Analysis products
  70 C                              1  - Forecast products
  71 C                              2  - Analysis and forecast products
  72 C                              3  - Control forecast products
  73 C                              4  - Perturbed forecast products
  74 C                              5  - Control and perturbed forecast products
  75 C                              6  - Processed satellite observations
  76 C                              7  - Processed radar observations
  77 C        gfld%idsectlen = Number of elements in gfld%idsect().
  78 C        gfld%local() = Pointer to character array containing contents
  79 C                       of Local Section 2, if included
  80 C        gfld%locallen = length of array gfld%local()
  81 C        gfld%ifldnum = field number within GRIB message
  82 C        gfld%griddef = Source of grid definition (see Code Table 3.0)
  83 C                      0 - Specified in Code table 3.1
  84 C                      1 - Predetermined grid Defined by originating centre
  85 C        gfld%ngrdpts = Number of grid points in the defined grid.
  86 C        gfld%numoct_opt = Number of octets needed for each
  87 C                          additional grid points definition.
  88 C                          Used to define number of
  89 C                          points in each row ( or column ) for
  90 C                          non-regular grids.
  91 C                          = 0, if using regular grid.
  92 C        gfld%interp_opt = Interpretation of list for optional points
  93 C                          definition.  (Code Table 3.11)
  94 C        gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
  95 C        gfld%igdtmpl() = Contains the data values for the specified Grid
  96 C                         Definition Template ( NN=gfld%igdtnum ).  Each
  97 C                         element of this integer array contains an entry (in
  98 C                         the order specified) of Grid Defintion Template 3.NN
  99 C                         This element is actually a pointer to an array
 100 C                         that holds the data.
 101 C        gfld%igdtlen = Number of elements in gfld%igdtmpl().  i.e. number of
 102 C                       entries in Grid Defintion Template 3.NN
 103 C                       ( NN=gfld%igdtnum ).
 104 C        gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0)  This array
 105 C                          contains the number of grid points contained in
 106 C                          each row ( or column ).  (part of Section 3)
 107 C                          This element is actually a pointer to an array
 108 C                          that holds the data.  This pointer is nullified
 109 C                          if gfld%numoct_opt=0.
 110 C        gfld%num_opt = (Used if gfld%numoct_opt .ne. 0)  The number of entries
 111 C                       in array ideflist.  i.e. number of rows ( or columns )
 112 C                       for which optional grid points are defined.  This value
 113 C                       is set to zero, if gfld%numoct_opt=0.
 114 C        gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
 115 C        gfld%ipdtmpl() = Contains the data values for the specified Product
 116 C                         Definition Template ( N=gfdl%ipdtnum ).  Each element
 117 C                         of this integer array contains an entry (in the
 118 C                         order specified) of Product Defintion Template 4.N.
 119 C                         This element is actually a pointer to an array
 120 C                         that holds the data.
 121 C        gfld%ipdtlen = Number of elements in gfld%ipdtmpl().  i.e. number of
 122 C                       entries in Product Defintion Template 4.N
 123 C                       ( N=gfdl%ipdtnum ).
 124 C        gfld%coord_list() = Real array containing floating point values
 125 C                            intended to document the vertical discretisation
 126 C                            associated to model data on hybrid coordinate
 127 C                            vertical levels.  (part of Section 4)
 128 C                            This element is actually a pointer to an array
 129 C                            that holds the data.
 130 C        gfld%num_coord = number of values in array gfld%coord_list().
 131 C        gfld%ndpts = Number of data points unpacked and returned.
 132 C        gfld%idrtnum = Data Representation Template Number
 133 C                       ( see Code Table 5.0)
 134 C        gfld%idrtmpl() = Contains the data values for the specified Data
 135 C                         Representation Template ( N=gfld%idrtnum ).  Each
 136 C                         element of this integer array contains an entry
 137 C                         (in the order specified) of Product Defintion
 138 C                         Template 5.N.
 139 C                         This element is actually a pointer to an array
 140 C                         that holds the data.
 141 C        gfld%idrtlen = Number of elements in gfld%idrtmpl().  i.e. number
 142 C                       of entries in Data Representation Template 5.N
 143 C                       ( N=gfld%idrtnum ).
 144 C        gfld%unpacked = logical value indicating whether the bitmap and
 145 C                        data values were unpacked.  If false,
 146 C                        gfld%bmap and gfld%fld pointers are nullified.
 147 C        gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
 148 C                     0 = bitmap applies and is included in Section 6.
 149 C                     1-253 = Predefined bitmap applies
 150 C                     254 = Previously defined bitmap applies to this field
 151 C                     255 = Bit map does not apply to this product.
 152 C        gfld%bmap() = Logical*1 array containing decoded bitmap,
 153 C                      if ibmap=0 or ibap=254.  Otherwise nullified.
 154 C                      This element is actually a pointer to an array
 155 C                      that holds the data.
 156 C        gfld%fld() = Array of gfld%ndpts unpacked data points.
 157 C                     This element is actually a pointer to an array
 158 C                     that holds the data.
 159 C
 160 C   OUTPUT ARGUMENTS:
 161 C     IRET         INTEGER RETURN CODE
 162 C                    0      ALL OK
 163 C                    2      MEMORY ALLOCATION ERROR
 164 C                    10     No Section 1 info available
 165 C                    11     No Grid Definition Template info available
 166 C                    12     Missing some required data field info
 167 C
 168 C SUBPROGRAMS CALLED:
 169 C   gribcreate     Start a new grib2 message
 170 C   addlocal       Add local section to a GRIB2 message
 171 C   addgrid        Add grid info to a GRIB2 message
 172 C   addfield       Add data field to a GRIB2 message
 173 C   gribend        End GRIB2 message
 174 C
 175 C REMARKS:
 176 C
 177 C   Note that derived type gribfield contains pointers to many
 178 C   arrays of data.  The memory for these arrays is allocated
 179 C   when the values in the arrays are set, to help minimize
 180 C   problems with array overloading.  Because of this users
 181 C   are encouraged to free up this memory, when it is no longer
 182 C   needed, by an explicit call to subroutine gf_free.
 183 C   ( i.e.   CALL GF_FREE(GFLD) )
 184 C
 185 C ATTRIBUTES:
 186 C   LANGUAGE: FORTRAN 90
 187 C
 188 C$$$
 189       USE GRIB_MOD
 190
 191       INTEGER,INTENT(IN) :: LUGB
 192       TYPE(GRIBFIELD),INTENT(IN) :: GFLD
 193       INTEGER,INTENT(OUT) :: IRET
 194
 195       CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CGRIB
 196       integer :: listsec0(2)=(/0,2/)
 197       integer :: igds(5)=(/0,0,0,0,0/)
 198       real    :: coordlist=0.0
 199       integer :: ilistopt=0
 200
 201 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 202 C  ALLOCATE ARRAY FOR GRIB2 FIELD
 203       lcgrib=gfld%ngrdpts*4
 204       allocate(cgrib(lcgrib),stat=is)
 205       if ( is.ne.0 ) then
 206          print *,'putgb2: cannot allocate memory. ',is
 207          iret=2
 208       endif
 209 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 210 C  CREATE NEW MESSAGE
 211       listsec0(1)=gfld%discipline
 212       listsec0(2)=gfld%version
 213       if ( associated(gfld%idsect) ) then
 214          call gribcreate(cgrib,lcgrib,listsec0,gfld%idsect,ierr)
 215          if (ierr.ne.0) then
 216             write(6,*) 'putgb2: ERROR creating new GRIB2 field = ',ierr
 217          endif
 218       else
 219          print *,'putgb2: No Section 1 info available. '
 220          iret=10
 221          deallocate(cgrib)
 222          return
 223       endif
 224 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 225 C  ADD LOCAL USE SECTION TO GRIB2 MESSAGE
 226       if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then
 227          call addlocal(cgrib,lcgrib,gfld%local,gfld%locallen,ierr)
 228          if (ierr.ne.0) then
 229             write(6,*) 'putgb2: ERROR adding local info = ',ierr
 230          endif
 231       endif
 232 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 233 C  ADD GRID TO GRIB2 MESSAGE
 234       igds(1)=gfld%griddef
 235       igds(2)=gfld%ngrdpts
 236       igds(3)=gfld%numoct_opt
 237       igds(4)=gfld%interp_opt
 238       igds(5)=gfld%igdtnum
 239       if ( associated(gfld%igdtmpl) ) then
 240          call addgrid(cgrib,lcgrib,igds,gfld%igdtmpl,gfld%igdtlen,
 241      &                ilistopt,gfld%num_opt,ierr)
 242          if (ierr.ne.0) then
 243             write(6,*) 'putgb2: ERROR adding grid info = ',ierr
 244          endif
 245       else
 246          print *,'putgb2: No GDT info available. '
 247          iret=11
 248          deallocate(cgrib)
 249          return
 250       endif
 251 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 252 C  ADD DATA FIELD TO GRIB2 MESSAGE
 253       if ( associated(gfld%ipdtmpl).AND.
 254      &     associated(gfld%idrtmpl).AND.
 255      &     associated(gfld%fld) ) then
 256          call addfield(cgrib,lcgrib,gfld%ipdtnum,gfld%ipdtmpl,
 257      &                 gfld%ipdtlen,coordlist,gfld%num_coord,
 258      &                 gfld%idrtnum,gfld%idrtmpl,gfld%idrtlen,
 259      &                 gfld%fld,gfld%ngrdpts,gfld%ibmap,gfld%bmap,
 260      &                 ierr)
 261          if (ierr.ne.0) then
 262             write(6,*) 'putgb2: ERROR adding data field = ',ierr
 263          endif
 264       else
 265          print *,'putgb2: Missing some field info. '
 266          iret=12
 267          deallocate(cgrib)
 268          return
 269       endif
 270 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 271 C  CLOSE GRIB2 MESSAGE AND WRITE TO FILE
 272       call gribend(cgrib,lcgrib,lengrib,ierr)
 273       call wryte(lugb,lengrib,cgrib)
 274 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 275       deallocate(cgrib)
 276       RETURN
 277       END