get_prep_interp.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.
SUBROUTINE get_prep_interp(KNP_IN,KNP_OUT,PVEGTYPE,PPATCH_IN,PPATCH_OUT,KMASK_IN)
!
USE modd_data_cover_par, ONLY : nvegtype
!
USE modi_vegtype_to_patch
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
INTEGER, INTENT(IN) :: KNP_IN
INTEGER, INTENT(IN) :: KNP_OUT
REAL, DIMENSION(:,:), INTENT(IN) :: PVEGTYPE
REAL, DIMENSION(:,:), INTENT(IN) :: PPATCH_IN
REAL, DIMENSION(:,:), INTENT(OUT) :: PPATCH_OUT
INTEGER, DIMENSION(:,:), INTENT(IN), OPTIONAL :: KMASK_IN
!
INTEGER, DIMENSION(SIZE(PPATCH_OUT,1),SIZE(PPATCH_IN,2)) :: IMASK_IN
REAL, DIMENSION(SIZE(PPATCH_OUT,1),SIZE(PPATCH_OUT,2)) :: ZPATCH_OUT
INTEGER :: JP, JVEG, IP_I, IP_O, JI, IMASK, JP2
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('GET_PREP_INTERP',0,zhook_handle)
!

IF (PRESENT(kmask_in)) THEN
  imask_in(:,:) = kmask_in(:,:)
ELSE
  DO ji = 1,SIZE(imask_in,1)
    imask_in(ji,:) = ji
  ENDDO
ENDIF
! 
zpatch_out(:,:) = 0.
!
! if NPATCH (in) == NVEGTYPE, the arrays of patches is this of vegtypes
IF (knp_in==nvegtype) THEN
  !
  DO jveg = 1,nvegtype
    ! mask of the output patch in which is this vegtype
    ip_o = vegtype_to_patch(jveg,knp_out)
    DO ji = 1,SIZE(imask_in,1)
      imask = imask_in(ji,ip_o)
      IF (imask/=0) zpatch_out(imask,jveg) = pvegtype(ji,jveg)
    ENDDO
  ENDDO
  !
! if there is the same number of patches before / after, patch_out = patch_in
ELSEIF (knp_in==knp_out) THEN
  !
  ! the mask can be applied to the patches before and after
  DO jp2 = 1,SIZE(imask_in,2)
    DO ji = 1,SIZE(imask_in,1)
      imask = imask_in(ji,jp2)
      IF (imask/=0) zpatch_out(imask,jp2) = ppatch_in(ji,jp2)
    ENDDO
  ENDDO
  !
! less patches before than after
ELSEIF (knp_in<knp_out) THEN
  !
  ! to which input patch contributes each output patch?  
  DO jp = 1,knp_out
    ! which vegtype is in this output patch? 
    DO jveg = 1,nvegtype
      ! output patch in which is this vegtype
      ip_o = vegtype_to_patch(jveg,knp_out)
      ! input patch in which is this vegtype
      ip_i = vegtype_to_patch(jveg,knp_in)
      !
      ! if VEG is in JP
      IF (ip_o==jp) THEN
        ! the input patch takes the contribution of the output patch
        DO ji = 1,SIZE(imask_in,1)
          ! the mask is this of the current output patch
          imask = imask_in(ji,ip_o)
          IF (imask/=0) zpatch_out(imask,ip_i) = zpatch_out(imask,ip_i) + ppatch_in(ji,ip_o)
        ENDDO
        ! just one time if several vegtypes are in this patch JP
        EXIT
      ENDIF
    ENDDO
  ENDDO
  !
! more patches before than after
ELSEIF (knp_in>knp_out) THEN
  !
  ! for each input patch, what is the corresponding output patch? 
  DO jp = 1,knp_in
    ! which vegtype is in this output patch? 
    DO jveg = 1,nvegtype
      ! input patch in which is this vegtype
      ip_i = vegtype_to_patch(jveg,knp_in)
      ! output patch in which is this vegtype
      ip_o = vegtype_to_patch(jveg,knp_out)
      !
      ! if VEG is in JP
      IF (ip_i==jp) THEN
        ! this input patch gets the value of the corresponding output patch
        DO ji = 1,SIZE(imask_in,1)
          imask = imask_in(ji,ip_o)
          IF (imask/=0) zpatch_out(imask,ip_i) = ppatch_in(ji,ip_o)
        ENDDO
        ! just one time because another vegtype of IP_I will be also in IP_O
        EXIT
      ENDIF
    ENDDO
  ENDDO
  !
ENDIF
!
ppatch_out(:,:) = zpatch_out(:,:)
!
IF (lhook) CALL dr_hook('GET_PREP_INTERP',1,zhook_handle)
!
END SUBROUTINE get_prep_interp