ip_grid_mod.F90

Go to the documentation of this file.

 
 
module ip_grid_mod
  use ip_grid_descriptor_mod
  implicit none
 
  integer, public, parameter :: equid_cylind_grid_id_grib1 = 0
  integer, public, parameter :: mercator_grid_id_grib1 = 1
  integer, public, parameter :: lambert_conf_grid_id_grib1 = 3
  integer, public, parameter :: gaussian_grid_id_grib1 = 4
  integer, public, parameter :: polar_stereo_grid_id_grib1 = 5
  integer, public, parameter :: rot_equid_cylind_e_grid_id_grib1 = 203
  integer, public, parameter :: rot_equid_cylind_b_grid_id_grib1 = 205
 
  integer, public, parameter :: equid_cylind_grid_id_grib2 = 0
  integer, public, parameter :: rot_equid_cylind_grid_id_grib2 = 1
  integer, public, parameter :: mercator_grid_id_grib2 = 10
  integer, public, parameter :: polar_stereo_grid_id_grib2 = 20
  integer, public, parameter :: lambert_conf_grid_id_grib2 = 30
  integer, public, parameter :: gaussian_grid_id_grib2 = 40
  integer, public, parameter :: rot_equid_cylind_e_grid_id_grib2 = 32768
  integer, public, parameter :: rot_equid_cylind_b_grid_id_grib2 = 32769
 
  logical, public, save :: ncep_post_arakawa=.false. 
 
  private
  public :: ip_grid
  public :: gdswzd_interface
  public :: operator(==)
  public :: use_ncep_post_arakawa
  public :: unuse_ncep_post_arakawa
 
  type, abstract :: ip_grid
     class(ip_grid_descriptor), allocatable :: descriptor
     
     integer :: im
     integer :: jm
     integer :: nm
 
     integer :: nscan 
     integer :: kscan
 
     integer :: nscan_field_pos
     
     integer :: iwrap
     integer :: jwrap1
     integer :: jwrap2
     real :: rerth
     real :: eccen_squared
   contains
     procedure(init_grib1_interface), deferred :: init_grib1
     procedure(init_grib2_interface), deferred :: init_grib2
     procedure(gdswzd_interface), deferred :: gdswzd
     procedure :: field_pos
     generic :: init => init_grib1, init_grib2
  end type ip_grid
 
  abstract interface
 
     subroutine gdswzd_interface(self, iopt, npts, fill, xpts, ypts, rlon, rlat, nret, crot, srot, &
          xlon, xlat, ylon, ylat, area)
       import
       class(ip_grid), intent(in) :: self
       INTEGER,          INTENT(IN   ) :: IOPT, NPTS
       INTEGER,          INTENT(  OUT) :: NRET
       !
       REAL,             INTENT(IN   ) :: FILL
       REAL,             INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
       REAL,             INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
       REAL, OPTIONAL,   INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
       REAL, OPTIONAL,   INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
       REAL, OPTIONAL,   INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
     end subroutine gdswzd_interface
 
     subroutine init_grib1_interface(self, g1_desc)
       import
       class(ip_grid), intent(inout) :: self
       type(grib1_descriptor), intent(in) :: g1_desc
     end subroutine init_grib1_interface
 
     subroutine init_grib2_interface(self, g2_desc)
       import
       class(ip_grid), intent(inout) :: self
       type(grib2_descriptor), intent(in) :: g2_desc
     end subroutine init_grib2_interface
 
  end interface
 
  interface operator (==)
     module procedure is_same_grid
  end interface operator (==)
  
 
contains
 
  subroutine use_ncep_post_arakawa() bind(c)
    ncep_post_arakawa = .true.
  end subroutine use_ncep_post_arakawa
 
  subroutine unuse_ncep_post_arakawa() bind(c)
    ncep_post_arakawa = .false.
  end subroutine unuse_ncep_post_arakawa
 
  logical function is_same_grid(grid1, grid2)
    class(ip_grid), intent(in) :: grid1, grid2
    is_same_grid = grid1%descriptor == grid2%descriptor
  end function is_same_grid
 
  function field_pos(self, i, j)
    class(ip_grid), intent(in) :: self
    integer, intent(in) :: i, j
    integer :: field_pos
 
    integer :: ii, jj, im, jm
    integer :: iif, jjf, is1, iwrap
    integer :: jwrap1, jwrap2, kscan, nscan
 
    ! extract from navigation parameter array
    im=self%im
    jm=self%jm
    iwrap=self%iwrap
    jwrap1=self%jwrap1
    jwrap2=self%jwrap2
    nscan=self%nscan_field_pos
    kscan=self%kscan
 
    ! compute wraparounds in x and y if necessary and possible
    ii=i
    jj=j
    if(iwrap.gt.0) then
       ii=mod(i-1+iwrap,iwrap)+1
       if(j.lt.1.and.jwrap1.gt.0) then
          jj=jwrap1-j
          ii=mod(ii-1+iwrap/2,iwrap)+1
       elseif(j.gt.jm.and.jwrap2.gt.0) then
          jj=jwrap2-j
          ii=mod(ii-1+iwrap/2,iwrap)+1
       endif
    endif
 
    ! compute position for the appropriate scanning mode
    field_pos=0
    if(nscan.eq.0) then
       if(ii.ge.1.and.ii.le.im.and.jj.ge.1.and.jj.le.jm) field_pos=ii+(jj-1)*im
    elseif(nscan.eq.1) then
       if(ii.ge.1.and.ii.le.im.and.jj.ge.1.and.jj.le.jm) field_pos=jj+(ii-1)*jm
    elseif(nscan.eq.2) then
       is1=(jm+1-kscan)/2
       iif=jj+(ii-is1)
       jjf=jj-(ii-is1)+kscan
       if(iif.ge.1.and.iif.le.2*im-1.and.jjf.ge.1.and.jjf.le.jm) &
            field_pos=(iif+(jjf-1)*(2*im-1)+1-kscan)/2
    elseif(nscan.eq.3) then
       is1=(jm+1-kscan)/2
       iif=jj+(ii-is1)
       jjf=jj-(ii-is1)+kscan
       if(iif.ge.1.and.iif.le.2*im-1.and.jjf.ge.1.and.jjf.le.jm) field_pos=(iif+1)/2+(jjf-1)*im
    endif
  end function field_pos
 
 
end module ip_grid_mod