external/io_grib2/g2lib/pdstemplates.F

   1       module pdstemplates
   2 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 !                .      .    .                                       .
   4 ! MODULE:    pdstemplates
   5 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
   6 !
   7 ! ABSTRACT: This Fortran Module contains info on all the available
   8 !   GRIB2 Product Definition Templates used in Section 4 (PDS).
   9 !   Each Template has three parts: The number of entries in the template
  10 !   (mapgridlen);  A map of the template (mapgrid), which contains the
  11 !   number of octets in which to pack each of the template values; and
  12 !   a logical value (needext) that indicates whether the Template needs
  13 !   to be extended.  In some cases the number of entries in a template
  14 !   can vary depending upon values specified in the "static" part of
  15 !   the template.  ( See Template 4.3 as an example )
  16 !
  17 !   This module also contains two subroutines.  Subroutine getpdstemplate
  18 !   returns the octet map for a specified Template number, and
  19 !   subroutine extpdstemplate will calculate the extended octet map
  20 !   of an appropriate template given values for the "static" part of the
  21 !   template.  See docblocks below for the arguments and usage of these
  22 !   routines.
  23 !
  24 !   NOTE:  Array mapgrid contains the number of octets in which the
  25 !   corresponding template values will be stored.  A negative value in
  26 !   mapgrid is used to indicate that the corresponding template entry can
  27 !   contain negative values.  This information is used later when packing
  28 !   (or unpacking) the template data values.  Negative data values in GRIB
  29 !   are stored with the left most bit set to one, and a negative number
  30 !   of octets value in mapgrid() indicates that this possibility should
  31 !   be considered.  The number of octets used to store the data value
  32 !   in this case would be the absolute value of the negative value in
  33 !   mapgrid().
  34 !
  35 !
  36 ! PROGRAM HISTORY LOG:
  37 ! 2000-05-11  Gilbert
  38 ! 2001-12-04  Gilbert  -  Added Templates 4.12, 4.12, 4.14,
  39 !                         4.1000, 4.1001, 4.1002, 4.1100 and 4.1101
  40 !
  41 ! USAGE:    use pdstemplates
  42 !
  43 ! ATTRIBUTES:
  44 !   LANGUAGE: Fortran 90
  45 !   MACHINE:  IBM SP
  46 !
  47 !$$$
  48
  49       integer,parameter :: MAXLEN=200,MAXTEMP=23
  50
  51       type pdstemplate
  52           integer :: template_num
  53           integer :: mappdslen
  54           integer,dimension(MAXLEN) :: mappds
  55           logical :: needext
  56       end type pdstemplate
  57
  58       type(pdstemplate),dimension(MAXTEMP) :: templates
  59
  60       data templates(1)%template_num /0/     !  Fcst at Level/Layer
  61       data templates(1)%mappdslen /15/
  62       data templates(1)%needext /.false./
  63       data (templates(1)%mappds(j),j=1,15)
  64      &                             /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
  65
  66       data templates(2)%template_num /1/     !  Ens fcst at level/layer
  67       data templates(2)%mappdslen /18/
  68       data templates(2)%needext /.false./
  69       data (templates(2)%mappds(j),j=1,18)
  70      &                        /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/
  71
  72       data templates(3)%template_num /2/     !  Derived Ens fcst at level/layer
  73       data templates(3)%mappdslen /17/
  74       data templates(3)%needext /.false./
  75       data (templates(3)%mappds(j),j=1,17)
  76      &                      /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1/
  77
  78       data templates(4)%template_num /3/     !  Ens cluster fcst rect. area
  79       data templates(4)%mappdslen /31/
  80       data templates(4)%needext /.true./
  81       data (templates(4)%mappds(j),j=1,31)
  82      &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4,
  83      &        1,-1,4,-1,4/
  84
  85       data templates(5)%template_num /4/     !  Ens cluster fcst circ. area
  86       data templates(5)%mappdslen /30/
  87       data templates(5)%needext /.true./
  88       data (templates(5)%mappds(j),j=1,30)
  89      &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4,
  90      &        1,-1,4,-1,4/
  91
  92       data templates(6)%template_num /5/     !  Prob fcst at level/layer
  93       data templates(6)%mappdslen /22/
  94       data templates(6)%needext /.false./
  95       data (templates(6)%mappds(j),j=1,22)
  96      &               /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,4,1,4/
  97
  98       data templates(7)%template_num /6/     !  Percentile fcst at level/layer
  99       data templates(7)%mappdslen /16/
 100       data templates(7)%needext /.false./
 101       data (templates(7)%mappds(j),j=1,16)
 102      &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/
 103
 104       data templates(8)%template_num /7/     !  Error at level/layer
 105       data templates(8)%mappdslen /15/
 106       data templates(8)%needext /.false./
 107       data (templates(8)%mappds(j),j=1,15)
 108      &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
 109
 110       data templates(9)%template_num /8/     !  Ave or Accum at level/layer
 111       data templates(9)%mappdslen /29/
 112       data templates(9)%needext /.true./
 113       data (templates(9)%mappds(j),j=1,29)
 114      &  /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
 115
 116       data templates(10)%template_num /9/     !  Prob over time interval
 117       data templates(10)%mappdslen /36/
 118       data templates(10)%needext /.true./
 119       data (templates(10)%mappds(j),j=1,36)
 120      &  /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,4,-1,4,2,1,1,1,1,1,
 121      &   1,4,1,1,1,4,1,4/
 122
 123       data templates(11)%template_num /10/     !  Percentile over time interval
 124       data templates(11)%mappdslen /30/
 125       data templates(11)%needext /.true./
 126       data (templates(11)%mappds(j),j=1,30)
 127      &    /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,2,1,1,1,1,1,1,4,
 128      &     1,1,1,4,1,4/
 129
 130       data templates(12)%template_num /11/     !  Ens member over time interval
 131       data templates(12)%mappdslen /32/
 132       data templates(12)%needext /.true./
 133       data (templates(12)%mappds(j),j=1,32)
 134      &    /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1,
 135      &     4,1,1,1,4,1,4/
 136
 137       data templates(13)%template_num /12/     !  Derived Ens fcst over time int
 138       data templates(13)%mappdslen /31/
 139       data templates(13)%needext /.true./
 140       data (templates(13)%mappds(j),j=1,31)
 141      &                   /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,
 142      &                    2,1,1,1,1,1,1,4,1,1,1,4,1,4/
 143
 144       data templates(14)%template_num /13/     !  Ens cluster fcst rect. area
 145       data templates(14)%mappdslen /45/
 146       data templates(14)%needext /.true./
 147       data (templates(14)%mappds(j),j=1,45)
 148      &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4,
 149      &        1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
 150
 151       data templates(15)%template_num /14/     !  Ens cluster fcst circ. area
 152       data templates(15)%mappdslen /44/
 153       data templates(15)%needext /.true./
 154       data (templates(15)%mappds(j),j=1,44)
 155      &       /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4,
 156      &        1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/
 157
 158       data templates(16)%template_num /20/     !  Radar Product
 159       data templates(16)%mappdslen /19/
 160       data templates(16)%needext /.false./
 161       data (templates(16)%mappds(j),j=1,19)
 162      &                     /1,1,1,1,1,-4,4,2,4,2,1,1,1,1,1,2,1,3,2/
 163
 164       data templates(17)%template_num /30/     !  Satellite Product
 165       data templates(17)%mappdslen /5/
 166       data templates(17)%needext /.true./
 167       data (templates(17)%mappds(j),j=1,5)
 168      &                            /1,1,1,1,1/
 169
 170       data templates(18)%template_num /254/     !  CCITTIA5 Character String
 171       data templates(18)%mappdslen /3/
 172       data templates(18)%needext /.false./
 173       data (templates(18)%mappds(j),j=1,3)
 174      &                     /1,1,4/
 175
 176       data templates(19)%template_num /1000/     !  Cross section
 177       data templates(19)%mappdslen /9/
 178       data templates(19)%needext /.false./
 179       data (templates(19)%mappds(j),j=1,9)
 180      &                     /1,1,1,1,1,2,1,1,4/
 181
 182       data templates(20)%template_num /1001/     !  Cross section over time
 183       data templates(20)%mappdslen /16/
 184       data templates(20)%needext /.false./
 185       data (templates(20)%mappds(j),j=1,16)
 186      &                     /1,1,1,1,1,2,1,1,4,4,1,1,1,4,1,4/
 187
 188       data templates(21)%template_num /1002/     !  Cross section processed time
 189       data templates(21)%mappdslen /15/
 190       data templates(21)%needext /.false./
 191       data (templates(21)%mappds(j),j=1,15)
 192      &                     /1,1,1,1,1,2,1,1,4,1,1,1,4,4,2/
 193
 194       data templates(22)%template_num /1100/     !  Hovmoller grid
 195       data templates(22)%mappdslen /15/
 196       data templates(22)%needext /.false./
 197       data (templates(22)%mappds(j),j=1,15)
 198      &                     /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/
 199
 200       data templates(23)%template_num /1101/     !  Hovmoller with stat proc
 201       data templates(23)%mappdslen /22/
 202       data templates(23)%needext /.false./
 203       data (templates(23)%mappds(j),j=1,22)
 204      &               /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,4,1,1,1,4,1,4/
 205
 206
 207       contains
 208
 209          integer function getpdsindex(number)
 210 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
 211 !                .      .    .                                       .
 212 ! SUBPROGRAM:    getpdsindex
 213 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-28
 214 !
 215 ! ABSTRACT: This function returns the index of specified Product
 216 !   Definition Template 4.NN (NN=number) in array templates.
 217 !
 218 ! PROGRAM HISTORY LOG:
 219 ! 2001-06-28  Gilbert
 220 !
 221 ! USAGE:    index=getpdsindex(number)
 222 !   INPUT ARGUMENT LIST:
 223 !     number   - NN, indicating the number of the Product Definition
 224 !                Template 4.NN that is being requested.
 225 !
 226 ! RETURNS:  Index of PDT 4.NN in array templates, if template exists.
 227 !           = -1, otherwise.
 228 !
 229 ! REMARKS: None
 230 !
 231 ! ATTRIBUTES:
 232 !   LANGUAGE: Fortran 90
 233 !   MACHINE:  IBM SP
 234 !
 235 !$$$
 236            integer,intent(in) :: number
 237
 238            getpdsindex=-1
 239
 240            do j=1,MAXTEMP
 241               if (number.eq.templates(j)%template_num) then
 242                  getpdsindex=j
 243                  return
 244               endif
 245            enddo
 246
 247          end function
 248
 249
 250
 251
 252          subroutine getpdstemplate(number,nummap,map,needext,iret)
 253 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
 254 !                .      .    .                                       .
 255 ! SUBPROGRAM:    getpdstemplate
 256 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
 257 !
 258 ! ABSTRACT: This subroutine returns PDS template information for a
 259 !   specified Product Definition Template 4.NN.
 260 !   The number of entries in the template is returned along with a map
 261 !   of the number of octets occupied by each entry.  Also, a flag is
 262 !   returned to indicate whether the template would need to be extended.
 263 !
 264 ! PROGRAM HISTORY LOG:
 265 ! 2000-05-11  Gilbert
 266 !
 267 ! USAGE:    CALL getpdstemplate(number,nummap,map,needext,iret)
 268 !   INPUT ARGUMENT LIST:
 269 !     number   - NN, indicating the number of the Product Definition
 270 !                Template 4.NN that is being requested.
 271 !
 272 !   OUTPUT ARGUMENT LIST:
 273 !     nummap   - Number of entries in the Template
 274 !     map()    - An array containing the number of octets that each
 275 !                template entry occupies when packed up into the PDS.
 276 !     needext  - Logical variable indicating whether the Product Defintion
 277 !                Template has to be extended.
 278 !     ierr     - Error return code.
 279 !                0 = no error
 280 !                1 = Undefine Product Template number.
 281 !
 282 ! REMARKS: None
 283 !
 284 ! ATTRIBUTES:
 285 !   LANGUAGE: Fortran 90
 286 !   MACHINE:  IBM SP
 287 !
 288 !$$$
 289            integer,intent(in) :: number
 290            integer,intent(out) :: nummap,map(*),iret
 291            logical,intent(out) :: needext
 292
 293            iret=0
 294
 295            index=getpdsindex(number)
 296
 297            if (index.ne.-1) then
 298               nummap=templates(index)%mappdslen
 299               needext=templates(index)%needext
 300               map(1:nummap)=templates(index)%mappds(1:nummap)
 301            else
 302              nummap=0
 303              needext=.false.
 304              print *,'getpdstemplate: PDS Template ',number,
 305      &               ' not defined.'
 306              iret=1
 307            endif
 308
 309          end subroutine
 310
 311          subroutine extpdstemplate(number,list,nummap,map)
 312 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
 313 !                .      .    .                                       .
 314 ! SUBPROGRAM:    extpdstemplate
 315 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
 316 !
 317 ! ABSTRACT: This subroutine generates the remaining octet map for a
 318 !   given Product Definition Template, if required.  Some Templates can
 319 !   vary depending on data values given in an earlier part of the
 320 !   Template, and it is necessary to know some of the earlier entry
 321 !   values to generate the full octet map of the Template.
 322 !
 323 ! PROGRAM HISTORY LOG:
 324 ! 2000-05-11  Gilbert
 325 !
 326 ! USAGE:    CALL extpdstemplate(number,list,nummap,map)
 327 !   INPUT ARGUMENT LIST:
 328 !     number   - NN, indicating the number of the Product Definition
 329 !                Template 4.NN that is being requested.
 330 !     list()   - The list of values for each entry in the
 331 !                the Product Definition Template 4.NN.
 332 !
 333 !   OUTPUT ARGUMENT LIST:
 334 !     nummap   - Number of entries in the Template
 335 !     map()    - An array containing the number of octets that each
 336 !                template entry occupies when packed up into the GDS.
 337 !
 338 ! ATTRIBUTES:
 339 !   LANGUAGE: Fortran 90
 340 !   MACHINE:  IBM SP
 341 !
 342 !$$$
 343            integer,intent(in) :: number,list(*)
 344            integer,intent(out) :: nummap,map(*)
 345
 346            index=getpdsindex(number)
 347            if (index.eq.-1) return
 348
 349            if ( .not. templates(index)%needext ) return
 350            nummap=templates(index)%mappdslen
 351            map(1:nummap)=templates(index)%mappds(1:nummap)
 352
 353            if ( number.eq.3 ) then
 354               N=list(27)
 355               do i=1,N
 356                 map(nummap+i)=1
 357               enddo
 358               nummap=nummap+N
 359            elseif ( number.eq.4 ) then
 360               N=list(26)
 361               do i=1,N
 362                 map(nummap+i)=1
 363               enddo
 364               nummap=nummap+N
 365            elseif ( number.eq.8 ) then
 366               if ( list(22).gt.1 ) then
 367                 do j=2,list(22)
 368                   do k=1,6
 369                     map(nummap+k)=map(23+k)
 370                   enddo
 371                   nummap=nummap+6
 372                 enddo
 373               endif
 374            elseif ( number.eq.9 ) then
 375               if ( list(29).gt.1 ) then
 376                 do j=2,list(29)
 377                   do k=1,6
 378                     map(nummap+k)=map(30+k)
 379                   enddo
 380                   nummap=nummap+6
 381                 enddo
 382               endif
 383            elseif ( number.eq.10 ) then
 384               if ( list(23).gt.1 ) then
 385                 do j=2,list(23)
 386                   do k=1,6
 387                     map(nummap+k)=map(24+k)
 388                   enddo
 389                   nummap=nummap+6
 390                 enddo
 391               endif
 392            elseif ( number.eq.11 ) then
 393               if ( list(25).gt.1 ) then
 394                 do j=2,list(25)
 395                   do k=1,6
 396                     map(nummap+k)=map(26+k)
 397                   enddo
 398                   nummap=nummap+6
 399                 enddo
 400               endif
 401            elseif ( number.eq.12 ) then
 402               if ( list(24).gt.1 ) then
 403                 do j=2,list(24)
 404                   do k=1,6
 405                     map(nummap+k)=map(25+k)
 406                   enddo
 407                   nummap=nummap+6
 408                 enddo
 409               endif
 410            elseif ( number.eq.13 ) then
 411               if ( list(38).gt.1 ) then
 412                 do j=2,list(38)
 413                   do k=1,6
 414                     map(nummap+k)=map(39+k)
 415                   enddo
 416                   nummap=nummap+6
 417                 enddo
 418               endif
 419               N=list(27)
 420               do i=1,N
 421                 map(nummap+i)=1
 422               enddo
 423               nummap=nummap+N
 424            elseif ( number.eq.14 ) then
 425               if ( list(37).gt.1 ) then
 426                 do j=2,list(37)
 427                   do k=1,6
 428                     map(nummap+k)=map(38+k)
 429                   enddo
 430                   nummap=nummap+6
 431                 enddo
 432               endif
 433               N=list(26)
 434               do i=1,N
 435                 map(nummap+i)=1
 436               enddo
 437               nummap=nummap+N
 438            elseif ( number.eq.30 ) then
 439               do j=1,list(5)
 440                 map(nummap+1)=2
 441                 map(nummap+2)=2
 442                 map(nummap+3)=1
 443                 map(nummap+4)=1
 444                 map(nummap+5)=4
 445                 nummap=nummap+5
 446               enddo
 447            endif
 448
 449          end subroutine
 450
 451          integer function getpdtlen(number)
 452 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
 453 !                .      .    .                                       .
 454 ! SUBPROGRAM:    getpdtlen
 455 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2004-05-11
 456 !
 457 ! ABSTRACT: This function returns the initial length (number of entries) in
 458 !   the "static" part of specified Product Definition Template 4.number.
 459 !
 460 ! PROGRAM HISTORY LOG:
 461 ! 2004-05-11  Gilbert
 462 !
 463 ! USAGE:    CALL getpdtlen(number)
 464 !   INPUT ARGUMENT LIST:
 465 !     number   - NN, indicating the number of the Product Definition
 466 !                Template 4.NN that is being requested.
 467 !
 468 ! RETURNS:     Number of entries in the "static" part of PDT 4.number
 469 !              OR returns 0, if requested template is not found.
 470 !
 471 ! REMARKS: If user needs the full length of a specific template that
 472 !    contains additional entries based on values set in the "static" part
 473 !    of the PDT, subroutine extpdstemplate can be used.
 474 !
 475 ! ATTRIBUTES:
 476 !   LANGUAGE: Fortran 90
 477 !   MACHINE:  IBM SP
 478 !
 479 !$$$
 480            integer,intent(in) :: number
 481
 482            getpdtlen=0
 483
 484            index=getpdsindex(number)
 485
 486            if (index.ne.-1) then
 487               getpdtlen=templates(index)%mappdslen
 488            endif
 489
 490          end function
 491
 492
 493       end module
 494