vegtype_grid_to_patch_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.
!     #########
SUBROUTINE vegtype_grid_to_patch_grid(KPATCH,PVEGTYPE_PATCH,PPATCH,PFIELDOUT,PW)
!        ################################################
!!
!!****  *VEGTYPE_GRID_TO_PATCH_GRID* averages fields from all (12) vegtypes 
!!                                   on only a few patches
!!    PURPOSE
!!    -------
!
!              
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!
!!      
!!    AUTHOR
!!    ------
!!
!!      V. Masson          * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!
!-------------------------------------------------------------------------------

!
USE modd_surf_par,       ONLY : xundef
USE modd_data_cover_par, ONLY : nvegtype
!
USE modi_vegtype_to_patch
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!
!*      0.1    declarations of arguments
!
INTEGER, INTENT(IN) :: kpatch
REAL, DIMENSION(:,:,:), INTENT(IN)                          :: pvegtype_patch
REAL, DIMENSION(:,:), INTENT(IN)                            :: ppatch
REAL, DIMENSION(:,:,:), INTENT(IN)                          :: pfieldout
REAL, DIMENSION(:,:,:), INTENT(OUT)                         :: pw
!
!
!*      0.2    declarations of local variables
!
INTEGER                       :: jpatch    ! loop on patches
INTEGER                       :: jvegtype  ! loop on vegtypes
INTEGER                       :: jlayer    ! loop on layers
REAL(KIND=JPRB) :: zhook_handle
!
!---------------------------------------------------------------------------
!
!* averages from vegtypes to chosen number of patches
IF (lhook) CALL dr_hook('VEGTYPE_GRID_TO_PATCH_GRID',0,zhook_handle)
pw(:,:,:) = 0.
DO jvegtype=1,nvegtype
  jpatch = vegtype_to_patch(jvegtype,kpatch)
  DO jlayer=1,SIZE(pw,2)
    pw(:,jlayer,jpatch) = pw(:,jlayer,jpatch)                                            &
                          + pvegtype_patch(:,jvegtype,jpatch) * pfieldout(:,jlayer,jvegtype)  
  END DO
END DO
!
!* insures undefined value when patch is not present
DO jpatch=1,kpatch
  DO jlayer=1,SIZE(pw,2)
    WHERE(ppatch(:,jpatch)==0.) pw(:,jlayer,jpatch) = xundef
  END DO
END DO
WHERE( abs(pw-xundef)/xundef < 1.e-6 ) pw = xundef
IF (lhook) CALL dr_hook('VEGTYPE_GRID_TO_PATCH_GRID',1,zhook_handle)
!
!---------------------------------------------------------------------------
!
END SUBROUTINE vegtype_grid_to_patch_grid