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