ipolatev.F90

Go to the documentation of this file.

 
 
module ipolatev_mod
  use ip_interpolators_mod
  use ip_grid_factory_mod
  use ip_grid_descriptor_mod
  use ip_grid_mod
 
  implicit none
 
  private
  public :: ipolatev, ipolatev_grib2, ipolatev_grib1_single_field, ipolatev_grib1, ipolatev_grib2_single_field
 
  interface ipolatev
     module procedure ipolatev_grib1
     module procedure ipolatev_grib1_single_field
     module procedure ipolatev_grib2
     module procedure ipolatev_grib2_single_field
  end interface ipolatev
  
contains
 
  SUBROUTINE ipolatev_grid(IP,IPOPT,grid_in,grid_out, &
       MI,MO,KM,IBI,LI,UI,VI, &
       NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
    class(ip_grid), intent(in) :: grid_in, grid_out
    INTEGER,               INTENT(IN   ) :: IP, IPOPT(20), IBI(KM)
    INTEGER,               INTENT(IN   ) :: KM, MI, MO
    INTEGER,               INTENT(  OUT) :: IBO(KM), IRET, NO
    !
    LOGICAL*1,             INTENT(IN   ) :: LI(MI,KM)
    LOGICAL*1,             INTENT(  OUT) :: LO(MO,KM)
    !
    REAL,                  INTENT(IN   ) :: UI(MI,KM),VI(MI,KM)
    REAL,                  INTENT(INOUT) :: CROT(MO),SROT(MO)
    REAL,                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL,                  INTENT(  OUT) :: UO(MO,KM),VO(MO,KM)
 
    select case(ip)
    case(bilinear_interp_id)
       CALL interpolate_bilinear(ipopt,grid_in,grid_out, &
            mi,mo,km,ibi,li,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case(bicubic_interp_id)
       CALL interpolate_bicubic(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case(neighbor_interp_id)
       CALL interpolate_neighbor(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case(budget_interp_id)
       CALL interpolate_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case(spectral_interp_id)
       CALL interpolate_spectral(ipopt,grid_in,grid_out, &
            mi,mo,km,ibi,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case(neighbor_budget_interp_id)
       CALL interpolate_neighbor_budget(ipopt,grid_in,grid_out,mi,mo,km,ibi,li,ui,vi,&
            no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
    case default
       print *, "unrecognized interpolation option: ", ip
       error stop
       ! IF(IGDTNUMO.GE.0) NO=0
       ! DO K=1,KM
       !    IBO(K)=1
       !    DO N=1,NO
       !       LO(N,K)=.FALSE.
       !       UO(N,K)=0.
       !       VO(N,K)=0.
       !    ENDDO
       ! ENDDO
       ! IRET=1
    end select
 
  end subroutine ipolatev_grid
  
  subroutine ipolatev_grib2(ip,ipopt,igdtnumi,igdtmpli,igdtleni, &
       igdtnumo,igdtmplo,igdtleno, &
       mi,mo,km,ibi,li,ui,vi, &
       no,rlat,rlon,crot,srot,ibo,lo,uo,vo,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), IBI(KM)
    INTEGER(C_LONG),               INTENT(IN   ) :: KM, MI, MO
    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) :: IBO(KM), IRET, NO
#else
    INTEGER(C_INT),               INTENT(IN   ) :: IP, IPOPT(20), IBI(KM)
    INTEGER(C_INT),               INTENT(IN   ) :: KM, MI, MO
    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) :: IBO(KM), IRET, NO
#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   ) :: UI(MI,KM),VI(MI,KM)
    REAL(C_FLOAT),                  INTENT(INOUT) :: CROT(MO),SROT(MO)
    REAL(C_FLOAT),                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),                  INTENT(  OUT) :: UO(MO,KM),VO(MO,KM)
#else
    REAL(C_DOUBLE),                  INTENT(IN   ) :: UI(MI,KM),VI(MI,KM)
    REAL(C_DOUBLE),                  INTENT(INOUT) :: CROT(MO),SROT(MO)
    REAL(C_DOUBLE),                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),                  INTENT(  OUT) :: UO(MO,KM),VO(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 ipolatev_grid(ip,ipopt,grid_in,grid_out, &
         mi,mo,km,ibi,li,ui,vi,&
         no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
 
  end subroutine ipolatev_grib2
 
  subroutine ipolatev_grib1(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,ui,vi, &
       no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c)
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
    IMPLICIT NONE
    !
#if (LSIZE==8)
    INTEGER(C_LONG),               INTENT(IN   ):: IP, IPOPT(20), IBI(KM)
    INTEGER(C_LONG),               INTENT(IN   ):: KM, MI, MO
    INTEGER(C_LONG),               INTENT(INOUT):: KGDSI(200), KGDSO(200)
    INTEGER(C_LONG),               INTENT(  OUT):: IBO(KM), IRET, NO
#else
    INTEGER(C_INT),               INTENT(IN   ):: IP, IPOPT(20), IBI(KM)
    INTEGER(C_INT),               INTENT(IN   ):: KM, MI, MO
    INTEGER(C_INT),               INTENT(INOUT):: KGDSI(200), KGDSO(200)
    INTEGER(C_INT),               INTENT(  OUT):: IBO(KM), IRET, NO
#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   ):: UI(MI,KM),VI(MI,KM)
    REAL(C_FLOAT),                  INTENT(INOUT):: CROT(MO),SROT(MO)
    REAL(C_FLOAT),                  INTENT(INOUT):: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),                  INTENT(  OUT):: UO(MO,KM),VO(MO,KM)
#else
    REAL(C_DOUBLE),                  INTENT(IN   ):: UI(MI,KM),VI(MI,KM)
    REAL(C_DOUBLE),                  INTENT(INOUT):: CROT(MO),SROT(MO)
    REAL(C_DOUBLE),                  INTENT(INOUT):: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),                  INTENT(  OUT):: UO(MO,KM),VO(MO,KM)
#endif
    !
    INTEGER                             :: KGDSI11, KGDSO11
 
    type(grib1_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
 
    IF(kgdsi(1).EQ.203) THEN
       kgdsi11=kgdsi(11)
       kgdsi(11)=ior(kgdsi(11),256)
    ENDIF
    IF(kgdso(1).EQ.203) THEN
       kgdso11=kgdso(11)
       kgdso(11)=ior(kgdso(11),256)
    ENDIF
 
    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 ipolatev_grid(ip,ipopt,grid_in,grid_out, &
         mi,mo,km,ibi,li,ui,vi,&
         no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret)
 
    IF(kgdsi(1).EQ.203) THEN
       kgdsi(11)=kgdsi11
    ENDIF
    IF(kgdso(1).EQ.203) THEN
       kgdso(11)=kgdso11
    ENDIF
 
  END SUBROUTINE ipolatev_grib1
 
  subroutine ipolatev_grib1_single_field(ip,ipopt,kgdsi,kgdso,mi,mo,km,ibi,li,ui,vi, &
       no,rlat,rlon,crot,srot,ibo,lo,uo,vo,iret) bind(c)
    USE iso_c_binding, ONLY: c_int, c_float, c_double, c_bool, c_long
    IMPLICIT NONE
    !
#if (LSIZE==8)
    INTEGER(C_LONG),               INTENT(IN   ):: IP, IPOPT(20), IBI
    INTEGER(C_LONG),               INTENT(IN   ):: KM, MI, MO
    INTEGER(C_LONG),               INTENT(INOUT):: KGDSI(200), KGDSO(200)
    INTEGER(C_LONG),               INTENT(  OUT):: IBO, IRET, NO
#else
    INTEGER(C_INT),               INTENT(IN   ):: IP, IPOPT(20), IBI
    INTEGER(C_INT),               INTENT(IN   ):: KM, MI, MO
    INTEGER(C_INT),               INTENT(INOUT):: KGDSI(200), KGDSO(200)
    INTEGER(C_INT),               INTENT(  OUT):: IBO, IRET, NO
#endif
    !
    LOGICAL(C_BOOL),             INTENT(IN   ):: LI(MI)
    LOGICAL(C_BOOL),             INTENT(  OUT):: LO(MO)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),                  INTENT(IN   ):: UI(MI),VI(MI)
    REAL(C_FLOAT),                  INTENT(INOUT):: CROT(MO),SROT(MO)
    REAL(C_FLOAT),                  INTENT(INOUT):: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),                  INTENT(  OUT):: UO(MO),VO(MO)
#else
    REAL(C_DOUBLE),                  INTENT(IN   ):: UI(MI),VI(MI)
    REAL(C_DOUBLE),                  INTENT(INOUT):: CROT(MO),SROT(MO)
    REAL(C_DOUBLE),                  INTENT(INOUT):: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),                  INTENT(  OUT):: UO(MO),VO(MO)
#endif
    !
    INTEGER                             :: KGDSI11, KGDSO11
 
    type(grib1_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
    integer :: ibo_array(1)
 
    ! 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
 
    IF(kgdsi(1).EQ.203) THEN
       kgdsi11=kgdsi(11)
       kgdsi(11)=ior(kgdsi(11),256)
    ENDIF
    IF(kgdso(1).EQ.203) THEN
       kgdso11=kgdso(11)
       kgdso(11)=ior(kgdso(11),256)
    ENDIF
 
    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 ipolatev_grid(ip,ipopt,grid_in,grid_out, &
         mi,mo,km,[ibi],li,ui,vi,&
         no,rlat,rlon,crot,srot,ibo_array,lo,uo,vo,iret)
 
    ibo = ibo_array(1)
 
    IF(kgdsi(1).EQ.203) THEN
       kgdsi(11)=kgdsi11
    ENDIF
    IF(kgdso(1).EQ.203) THEN
       kgdso(11)=kgdso11
    ENDIF
 
  END SUBROUTINE ipolatev_grib1_single_field
 
  subroutine ipolatev_grib2_single_field(ip,ipopt,igdtnumi,igdtmpli,igdtleni, &
       igdtnumo,igdtmplo,igdtleno, &
       mi,mo,km,ibi,li,ui,vi, &
       no,rlat,rlon,crot,srot,ibo,lo,uo,vo,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), IBI
    INTEGER(C_LONG),               INTENT(IN   ) :: KM, MI, MO
    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) :: IBO, IRET, NO
#else
    INTEGER(C_INT),               INTENT(IN   ) :: IP, IPOPT(20), IBI
    INTEGER(C_INT),               INTENT(IN   ) :: KM, MI, MO
    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) :: IBO, IRET, NO
#endif
    !
    LOGICAL(C_BOOL),             INTENT(IN   ) :: LI(MI)
    LOGICAL(C_BOOL),             INTENT(  OUT) :: LO(MO)
    !
#if (LSIZE==4)
    REAL(C_FLOAT),                  INTENT(IN   ) :: UI(MI),VI(MI)
    REAL(C_FLOAT),                  INTENT(INOUT) :: CROT(MO),SROT(MO)
    REAL(C_FLOAT),                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_FLOAT),                  INTENT(  OUT) :: UO(MO),VO(MO)
#else
    REAL(C_DOUBLE),                  INTENT(IN   ) :: UI(MI),VI(MI)
    REAL(C_DOUBLE),                  INTENT(INOUT) :: CROT(MO),SROT(MO)
    REAL(C_DOUBLE),                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
    REAL(C_DOUBLE),                  INTENT(  OUT) :: UO(MO),VO(MO)
#endif
    !
 
    type(grib2_descriptor) :: desc_in, desc_out
    class(ip_grid), allocatable :: grid_in, grid_out
    integer :: ibo_array(1)
 
    ! 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
 
    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 ipolatev_grid(ip,ipopt,grid_in,grid_out, &
         mi,mo,km,[ibi],li,ui,vi,&
         no,rlat,rlon,crot,srot,ibo_array,lo,uo,vo,iret)
 
    ibo = ibo_array(1)
 
  end subroutine ipolatev_grib2_single_field
 
end module ipolatev_mod