ipolates.F90

Go to the documentation of this file.

 
 
module ipolates_mod
  use ip_interpolators_mod
  use ip_grid_descriptor_mod
  use ip_grid_factory_mod, only: init_grid
  use ip_interpolators_mod
  use ip_grid_mod
  implicit none
 
  private
  public :: ipolates, ipolates_grib2, ipolates_grib1_single_field, ipolates_grib1, ipolates_grib2_single_field
 
  interface ipolates
     module procedure ipolates_grib1
     module procedure ipolates_grib1_single_field
     module procedure ipolates_grib2
     module procedure ipolates_grib2_single_field
  end interface ipolates
 
contains
 
  subroutine ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km,&
       & ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret)
    class(ip_grid), intent(in) :: grid_in, grid_out
    INTEGER,    INTENT(IN   ) :: IP, IPOPT(20), KM, MI, MO
    INTEGER,    INTENT(IN   ) :: IBI(KM)
    INTEGER,    INTENT(INOUT) :: NO
    INTEGER,    INTENT(  OUT) :: IRET, IBO(KM)
    !
    LOGICAL*1,  INTENT(IN   ) :: LI(MI,KM)
    LOGICAL*1,  INTENT(  OUT) :: LO(MO,KM)
    !
    REAL,       INTENT(IN   ) :: GI(MI,KM)
    REAL,       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL,       INTENT(  OUT) :: GO(MO,KM)
    !
 
    select case(ip)
    case(bilinear_interp_id)
       CALL interpolate_bilinear(ipopt,grid_in,grid_out,mi,mo,km,ibi&
            &,li,gi,no,rlat,rlon,ibo,lo,go,iret)
    case(bicubic_interp_id)
       CALL interpolate_bicubic(ipopt,grid_in,grid_out,mi,mo,km,ibi&
            &,li,gi,no,rlat,rlon,ibo,lo,go,iret)
    case(neighbor_interp_id)
       CALL interpolate_neighbor(ipopt,grid_in,grid_out,mi,mo,km,ibi&
            &,li,gi,no,rlat,rlon,ibo,lo,go,iret)
    case(budget_interp_id)
       CALL interpolate_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li&
            &,gi,no,rlat,rlon,ibo,lo,go,iret)
    case(spectral_interp_id)
       CALL interpolate_spectral(ipopt,grid_in,grid_out,mi,mo,km,ibi&
            &,gi,no,rlat,rlon,ibo,lo,go,iret)
    case(neighbor_budget_interp_id)
       CALL interpolate_neighbor_budget(ipopt,grid_in,grid_out,mi,mo&
            &,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret)
    case default
       ! IF(KGDSO(1).GE.0) NO=0
       ! DO K=1,KM
       !    IBO(K)=1
       !    DO N=1,NO
       !       LO(N,K)=.FALSE.
       !       GO(N,K)=0.
       !    ENDDO
       ! ENDDO
       iret=1
       print *, "Unrecognized interp option: ", ip
       error stop
    end select
 
  end subroutine ipolates_grid
 
   subroutine ipolates_grib1_single_field(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,gi, &
       no,rlat,rlon,ibo,lo,go,iret) bind(c)
    !
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
#if (LSIZE==8)
    INTEGER(C_LONG),    INTENT(IN   ) :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_LONG),    INTENT(IN   ) :: IBI, KGDSI(200), KGDSO(200)
    INTEGER(C_LONG),    INTENT(INOUT) :: NO
    INTEGER(C_LONG),    INTENT(  OUT) :: IRET, IBO
#else
    INTEGER(C_INT),    INTENT(IN   ) :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_INT),    INTENT(IN   ) :: IBI, KGDSI(200), KGDSO(200)
    INTEGER(C_INT),    INTENT(INOUT) :: NO
    INTEGER(C_INT),    INTENT(  OUT) :: IRET, IBO
#endif
    !
    LOGICAL(C_BOOL),  INTENT(IN   ) :: LI(MI)
    LOGICAL(C_BOOL),  INTENT(  OUT) :: LO(MO)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),       INTENT(IN   ) :: GI(MI)
    REAL(C_FLOAT),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),       INTENT(  OUT) :: GO(MO)
#else
    REAL(C_DOUBLE),       INTENT(IN   ) :: GI(MI)
    REAL(C_DOUBLE),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),       INTENT(  OUT) :: GO(MO)
#endif
    !
 
    type(grib1_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
    integer :: ibo_array(1)
 
    desc_in = init_descriptor(kgdsi)
    desc_out = init_descriptor(kgdso)
 
    call init_grid(grid_in, desc_in)
    call init_grid(grid_out, desc_out)
 
    ! Can't pass expression (e.g. [ibo]) to intent(out) argument.
    ! Initialize placeholder array of size 1 to make rank match.
    ibo_array(1) = ibo
 
    call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, [ibi], li, gi, no, rlat, rlon, ibo_array, lo, go, iret)
 
    ibo = ibo_array(1)
 
  END SUBROUTINE ipolates_grib1_single_field
 
  subroutine ipolates_grib1(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,gi, &
       no,rlat,rlon,ibo,lo,go,iret) bind(c)
    !
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
#if (LSIZE==8)
    INTEGER(C_LONG),    INTENT(IN   ) :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_LONG),    INTENT(IN   ) :: IBI(KM), KGDSI(200), KGDSO(200)
    INTEGER(C_LONG),    INTENT(INOUT) :: NO
    INTEGER(C_LONG),    INTENT(  OUT) :: IRET, IBO(KM)
#else
    INTEGER(C_INT),    INTENT(IN   ) :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_INT),    INTENT(IN   ) :: IBI(KM), KGDSI(200), KGDSO(200)
    INTEGER(C_INT),    INTENT(INOUT) :: NO
    INTEGER(C_INT),    INTENT(  OUT) :: IRET, IBO(KM)
#endif
    !
    LOGICAL(C_BOOL),  INTENT(IN   ) :: LI(MI,KM)
    LOGICAL(C_BOOL),  INTENT(  OUT) :: LO(MO,KM)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),       INTENT(IN   ) :: GI(MI,KM)
    REAL(C_FLOAT),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),       INTENT(  OUT) :: GO(MO,KM)
#else
    REAL(C_DOUBLE),       INTENT(IN   ) :: GI(MI,KM)
    REAL(C_DOUBLE),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),       INTENT(  OUT) :: GO(MO,KM)
#endif
    !
 
    type(grib1_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
 
    desc_in = init_descriptor(kgdsi)
    desc_out = init_descriptor(kgdso)
 
    call init_grid(grid_in, desc_in)
    call init_grid(grid_out, desc_out)
 
    call ipolates_grid(ip, ipopt, grid_in, grid_out, mi, mo, km, ibi, li, gi, no, rlat, rlon, ibo, lo, go, iret)
 
  END SUBROUTINE ipolates_grib1
  
  SUBROUTINE ipolates_grib2(IP,IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
       IGDTNUMO,IGDTMPLO,IGDTLENO, &
       MI,MO,KM,IBI,LI,GI, &
       NO,RLAT,RLON,IBO,LO,GO,IRET) bind(C)
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
#if (LSIZE==8)
    INTEGER(C_LONG),        INTENT(IN   )     :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_LONG),        INTENT(IN   )     :: IBI(KM)
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTNUMI, IGDTLENI
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTMPLI(IGDTLENI)
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTNUMO, IGDTLENO
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTMPLO(IGDTLENO)
    INTEGER(C_LONG),        INTENT(  OUT)     :: NO
    INTEGER(C_LONG),        INTENT(  OUT)     :: IRET, IBO(KM)
#else
    INTEGER(C_INT),        INTENT(IN   )     :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_INT),        INTENT(IN   )     :: IBI(KM)
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTNUMI, IGDTLENI
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTMPLI(IGDTLENI)
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTNUMO, IGDTLENO
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTMPLO(IGDTLENO)
    INTEGER(C_INT),        INTENT(  OUT)     :: NO
    INTEGER(C_INT),        INTENT(  OUT)     :: IRET, IBO(KM)
#endif
    !
    LOGICAL(C_BOOL),      INTENT(IN   )     :: LI(MI,KM)
    LOGICAL(C_BOOL),      INTENT(  OUT)     :: LO(MO,KM)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),       INTENT(IN   ) :: GI(MI,KM)
    REAL(C_FLOAT),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),       INTENT(  OUT) :: GO(MO,KM)
#else
    REAL(C_DOUBLE),       INTENT(IN   ) :: GI(MI,KM)
    REAL(C_DOUBLE),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),       INTENT(  OUT) :: GO(MO,KM)
#endif
 
    type(grib2_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
 
    desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli)
    desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo)
 
    call init_grid(grid_in, desc_in)
    call init_grid(grid_out, desc_out)
 
    CALL ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,ibi,li,gi,no,rlat,rlon,ibo,lo,go,iret)
 
  END SUBROUTINE ipolates_grib2
 
  SUBROUTINE ipolates_grib2_single_field(IP,IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
       IGDTNUMO,IGDTMPLO,IGDTLENO, &
       MI,MO,KM,IBI,LI,GI, &
       NO,RLAT,RLON,IBO,LO,GO,IRET) bind(C)
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
#if (LSIZE==8)
    INTEGER(C_LONG),        INTENT(IN   )     :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_LONG),        INTENT(IN   )     :: IBI
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTNUMI, IGDTLENI
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTMPLI(IGDTLENI)
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTNUMO, IGDTLENO
    INTEGER(C_LONG),        INTENT(IN   )     :: IGDTMPLO(IGDTLENO)
    INTEGER(C_LONG),        INTENT(  OUT)     :: NO
    INTEGER(C_LONG),        INTENT(  OUT)     :: IRET, IBO
#else
    INTEGER(C_INT),        INTENT(IN   )     :: IP, IPOPT(20), KM, MI, MO
    INTEGER(C_INT),        INTENT(IN   )     :: IBI
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTNUMI, IGDTLENI
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTMPLI(IGDTLENI)
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTNUMO, IGDTLENO
    INTEGER(C_INT),        INTENT(IN   )     :: IGDTMPLO(IGDTLENO)
    INTEGER(C_INT),        INTENT(  OUT)     :: NO
    INTEGER(C_INT),        INTENT(  OUT)     :: IRET, IBO
#endif
    !
    LOGICAL(C_BOOL),      INTENT(IN   )     :: LI(MI)
    LOGICAL(C_BOOL),      INTENT(  OUT)     :: LO(MO)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),       INTENT(IN   ) :: GI(MI)
    REAL(C_FLOAT),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),       INTENT(  OUT) :: GO(MO)
#else
    REAL(C_DOUBLE),       INTENT(IN   ) :: GI(MI)
    REAL(C_DOUBLE),       INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),       INTENT(  OUT) :: GO(MO)
#endif
 
    type(grib2_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
    integer :: ibo_array(1)
 
    desc_in = init_descriptor(igdtnumi, igdtleni, igdtmpli)
    desc_out = init_descriptor(igdtnumo, igdtleno, igdtmplo)
 
    call init_grid(grid_in, desc_in)
    call init_grid(grid_out, desc_out)
 
    ! Can't pass expression (e.g. [ibo]) to intent(out) argument.
    ! Initialize placeholder array of size 1 to make rank match.
    ibo_array(1) = ibo
 
    call ipolates_grid(ip,ipopt,grid_in,grid_out,mi,mo,km,[ibi],li,gi,no,rlat,rlon,ibo_array,lo,go,iret)
 
    ibo = ibo_array(1)
 
  END SUBROUTINE ipolates_grib2_single_field
 
end module ipolates_mod