external/io_grib2/g2lib/getpoly.F

   1       subroutine getpoly(csec3,lcsec3,jj,kk,mm)
   2 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   3 !                .      .    .                                       .
   4 ! SUBPROGRAM:    getpoly
   5 !   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2002-12-11
   6 !
   7 ! ABSTRACT: This subroutine returns the J, K, and M pentagonal resolution
   8 !   parameters specified in a GRIB Grid Definition Section used
   9 !   spherical harmonic coefficients using GDT 5.50 through 5.53
  10 !
  11 ! PROGRAM HISTORY LOG:
  12 ! 2002-12-11  Gilbert
  13 !
  14 ! USAGE:    CALL getpoly(csec3,lcsec3,jj,kk,mm)
  15 !   INPUT ARGUMENT LIST:
  16 !     csec3    - Character array that contains the packed GRIB2 GDS
  17 !    lcsec3    - Length (in octets) of section 3
  18 !
  19 !   OUTPUT ARGUMENT LIST:
  20 !         JJ   = J - pentagonal resolution parameter
  21 !         KK   = K - pentagonal resolution parameter
  22 !         MM   = M - pentagonal resolution parameter
  23 !
  24 ! REMARKS:  Returns JJ, KK, and MM set to zero, if grid template
  25 !           not recognized.
  26 !
  27 ! ATTRIBUTES:
  28 !   LANGUAGE: Fortran 90
  29 !   MACHINE:  IBM SP
  30 !
  31 !$$$
  32 !      use grib_mod
  33
  34       character(len=1),intent(in) :: csec3(*)
  35       integer,intent(in) :: lcsec3
  36       integer,intent(out) :: jj,kk,mm
  37
  38       integer,pointer,dimension(:) :: igdstmpl,list_opt
  39       integer :: igds(5)
  40       integer iofst,igdtlen,num_opt,jerr
  41
  42       interface
  43          subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
  44      &                         mapgridlen,ideflist,idefnum,ierr)
  45             character(len=1),intent(in) :: cgrib(lcgrib)
  46             integer,intent(in) :: lcgrib
  47             integer,intent(inout) :: iofst
  48             integer,pointer,dimension(:) :: igdstmpl,ideflist
  49             integer,intent(out) :: igds(5)
  50             integer,intent(out) :: ierr,idefnum
  51          end subroutine gf_unpack3
  52       end interface
  53
  54       nullify(igdstmpl,list_opt)
  55         !
  56       iofst=0       ! set offset to beginning of section
  57       call gf_unpack3(csec3,lcsec3,iofst,igds,igdstmpl,
  58      &                 igdtlen,list_opt,num_opt,jerr)
  59       if (jerr.eq.0) then
  60          selectcase( igds(5) )     !  Template number
  61            case (50:53)   ! Spherical harmonic coefficients
  62               jj=igdstmpl(1)
  63               kk=igdstmpl(2)
  64               mm=igdstmpl(3)
  65            case default
  66               jj=0
  67               kk=0
  68               mm=0
  69          end select
  70       else
  71          jj=0
  72          kk=0
  73          mm=0
  74       endif
  75         !
  76       if (associated(igdstmpl)) deallocate(igdstmpl)
  77       if (associated(list_opt)) deallocate(list_opt)
  78
  79       return
  80       end