interp_grid.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!######################
MODULE modi_interp_grid
!######################

INTERFACE interp_grid

SUBROUTINE interp_grid_1d(PZ1,PT1,PZ2,PT2)
!
REAL, DIMENSION(:,:), INTENT(IN)  :: PZ1  ! input vertical grid
REAL, DIMENSION(:,:), INTENT(IN)  :: PT1  ! input temperatures
REAL, DIMENSION(:),   INTENT(IN)  :: PZ2  ! output vertical grid
REAL, DIMENSION(:,:), INTENT(OUT)  :: PT2  ! output temperatures
!
END SUBROUTINE interp_grid_1d
!
SUBROUTINE interp_grid_2d(PZ1,PT1,PZ2,PT2)
!
REAL, DIMENSION(:,:), INTENT(IN) :: PZ1  ! input vertical grid
REAL, DIMENSION(:,:), INTENT(IN) :: PT1  ! input temperatures
REAL, DIMENSION(:,:), INTENT(IN) :: PZ2  ! output vertical grid
REAL, DIMENSION(:,:), INTENT(OUT) :: PT2  ! output temperatures
!
END SUBROUTINE interp_grid_2d
!
END INTERFACE

END MODULE modi_interp_grid

!     ##########################################
      SUBROUTINE interp_grid_1d(PZ1,PT1,PZ2,PT2)
!     ##########################################
!!
!!****  *INTERP_GRID* - interpolation on the vertical
!!
!!    PURPOSE
!!    -------
!!
!! input  grid/data is (x,z1)
!! output grid/data is (x,z2)
!!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!------------------------------------------------------------------
!
USE modd_surf_par,   ONLY : xundef
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!* 0.1 Declaration of dummy arguments
!
REAL, DIMENSION(:,:), INTENT(IN)   :: PZ1  ! input vertical grid
REAL, DIMENSION(:,:), INTENT(IN)   :: PT1  ! input temperatures
REAL, DIMENSION(:),   INTENT(IN)   :: PZ2  ! output vertical grid
REAL, DIMENSION(:,:), INTENT(OUT)  :: PT2  ! output temperatures
!
!* 0.2 Declaration of local variables
!
REAL, DIMENSION(SIZE(PZ1,2)-1) :: ZDIZ1
INTEGER :: JL, JI, JK, JK2 ! loop counter
REAL :: ZTHR
REAL :: ZEPS ! a small number
REAL :: ZCOEFLIN ! interpolation coefficients
INTEGER :: IKLIN    ! lower interpolating level of
INTEGER :: ILEVEL, IS1
!                                                     ! grid 1 for each level of grid 2 
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!-----------------------------------------------------------------------------
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_1D_1',0,zhook_handle)
!
is1 = SIZE(pz1,2)
!
zeps=1.e-12
!
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_1D_1',1,zhook_handle)
!
!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_1D_2',0,zhook_handle_omp)
!$OMP DO PRIVATE(JI,JK,ZDIZ1,JK2,ZTHR,ILEVEL,IKLIN,ZCOEFLIN)
DO ji = 1,SIZE(pz1,1)
  !
  IF (any(pt1(ji,:)==xundef)) THEN
    !
    pt2(ji,:)=xundef
    !
  ELSE
    !
    DO jk = 1,SIZE(pz1,2)-1
      IF (pz1(ji,jk)==pz1(ji,jk+1)) THEN
        zdiz1(jk) = 0.
      ELSE
        zdiz1(jk) = 1./(pz1(ji,jk)-pz1(ji,jk+1))
      ENDIF
    ENDDO
    !
    DO jk2 = 1,SIZE(pz2)
      !
      zthr = pz2(jk2) * (1.-zeps)
      ilevel = count(pz1(ji,:)<=zthr)
      !
      IF (ilevel < 1 ) THEN    ! no extrapolation
        !
        iklin = 1
        zcoeflin = 1.                               
        !
      ELSE
        !
        !* linear extrapolation
        ilevel = min(ilevel,is1-1)
        !
        iklin = ilevel 
        !
        zcoeflin = ( pz2(jk2)-pz1(ji,ilevel+1) ) * zdiz1(ilevel)
        IF (ilevel==is1-1) zcoeflin = max(zcoeflin,0.) ! no extrapolation
        !
      ENDIF
      !
      pt2(ji,jk2) = zcoeflin * pt1(ji,iklin) + (1.-zcoeflin) * pt1(ji,iklin+1)  
      !
    END DO
    !
  ENDIF
!-------------------------------------------------------------------------------
ENDDO
!$OMP ENDDO 
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_1D_2',1,zhook_handle_omp)
!$OMP END PARALLEL
!
!-----------------------------------------------------------------------------
END SUBROUTINE interp_grid_1d
!
!     ##########################################
      SUBROUTINE interp_grid_2d(PZ1,PT1,PZ2,PT2)
!     ##########################################
!
USE modd_surf_par,   ONLY : xundef
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!* 0.1 Declaration of dummy arguments
!
REAL, DIMENSION(:,:), INTENT(IN)  :: PZ1  ! input vertical grid
REAL, DIMENSION(:,:), INTENT(IN)  :: PT1  ! input temperatures
REAL, DIMENSION(:,:), INTENT(IN)  :: PZ2  ! output vertical grid
REAL, DIMENSION(:,:), INTENT(OUT) :: PT2  ! output temperatures
!
!* 0.2 Declaration of local variables
!
REAL, DIMENSION(SIZE(PZ1,2)-1) :: ZDIZ1
REAL :: ZTHR
REAL :: ZEPS ! a small number
REAL :: ZCOEFLIN ! interpolation coefficients
INTEGER :: JI, JK, JK2 ! loop counter
INTEGER :: IKLIN    ! lower interpolating level of
INTEGER :: ILEVEL, IS1
REAL(KIND=JPRB) :: ZHOOK_HANDLE, ZHOOK_HANDLE_OMP
!-----------------------------------------------------------------------------
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_2D_1',0,zhook_handle)
!
is1 = SIZE(pz1,2)
!
zeps=1.e-12
!
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_2D_1',1,zhook_handle)
!
!$OMP PARALLEL PRIVATE(ZHOOK_HANDLE_OMP)
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_2D_2',0,zhook_handle_omp)
!$OMP DO PRIVATE(JI,JK,ZDIZ1,JK2,ZTHR,ILEVEL,IKLIN,ZCOEFLIN)
DO ji = 1,SIZE(pz1,1)
  !
  IF (any(pt1(ji,:)==xundef)) THEN
    !
    pt2(ji,:)=xundef
    !
  ELSE
    !
    DO jk = 1,SIZE(pz1,2)-1
      IF (pz1(ji,jk)==pz1(ji,jk+1)) THEN
        zdiz1(jk) = 0.
      ELSE
        zdiz1(jk) = 1./(pz1(ji,jk)-pz1(ji,jk+1))
      ENDIF
    ENDDO
    !
    DO jk2 = 1,SIZE(pz2,2)
      !
      zthr = pz2(ji,jk2) * (1.-zeps)
      ilevel = count(pz1(ji,:)<=zthr)
      !
      IF (ilevel < 1 ) THEN
        !
        iklin = 1
        zcoeflin = 1.                       ! no extrapolation
        !
      ELSE
        !
        !* linear extrapolation 
        ilevel = min(ilevel,is1-1)
        iklin = ilevel
        !
        zcoeflin = ( pz2(ji,jk2)-pz1(ji,ilevel+1) ) * zdiz1(ilevel)
        IF (ilevel==is1-1) zcoeflin = max(zcoeflin,0.) ! no extrapolation
        !
      ENDIF
      !
      pt2(ji,jk2) = zcoeflin * pt1(ji,iklin) + (1.-zcoeflin) * pt1(ji,iklin+1)  
      !
    END DO
    !
  ENDIF
!-------------------------------------------------------------------------------
ENDDO
!$OMP ENDDO
IF (lhook) CALL dr_hook('MODI_INTERP_GRID:INTERP_GRID_2D_2',1,zhook_handle_omp)
!$OMP END PARALLEL
!
!-----------------------------------------------------------------------------
END SUBROUTINE interp_grid_2d
!