| 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 |
|---|
