avg_patch_wg.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 avg_patch_wg (I, &
                               ki,pwg,pwgi,pdg)
!     ##########################
!
!!
!!    PURPOSE
!!    -------
!      from  AVERAGE_DIAG_MISC_ISBA_n
!!     ONLY for 3L cases!!
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!
!!       ELYAZIDI/HEYMES/RISTOR * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original  02/2011 
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
!
!
USE modd_isba_n, ONLY : isba_t
!
USE modd_surf_par,  ONLY : xundef, nundef
USE yomhook   ,     ONLY : lhook,   dr_hook
USE parkind1  ,     ONLY : jprb
!
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments

!
TYPE(isba_t), INTENT(INOUT) :: i
!
 INTEGER, INTENT(IN)               :: ki
 REAL, DIMENSION(:,:), INTENT(OUT) :: pwg
 REAL, DIMENSION(:,:), INTENT(OUT) :: pwgi
 REAL, DIMENSION(:,:), INTENT(OUT) :: pdg
!      
!*      0.2    declarations of local variables
 INTEGER                         :: jj, jlayer, jpatch ! loop indexes
 INTEGER                         :: idepth 
 INTEGER                         :: ini, inp
 REAL                            :: zwork 
REAL, DIMENSION(SIZE(I%XPATCH,1)) :: zsumpatch
 !
 REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('AVG_PATCH_WG',0,zhook_handle)
!
ini=SIZE(i%XPATCH,1)
inp=SIZE(i%XPATCH,2)

zsumpatch(:) = 0.0
DO jpatch=1,inp
   DO jj=1,ini
      zsumpatch(jj) = zsumpatch(jj) + i%XPATCH(jj,jpatch)
   END DO
END DO

pwg(:,:) =0.0
pwgi(:,:)=0.0
pdg(:,:) =0.0
!
! 
IF (inp/=1)THEN
  DO jpatch=1,inp
     DO jj=1,ini     
        IF(zsumpatch(jj) > 0.)THEN
!
          zwork=max(0.0,i%XDG(jj,3,jpatch)-i%XDG(jj,2,jpatch))
          pwg(jj,1)  = pwg(jj,1)  + i%XPATCH(jj,jpatch) * i%XWG(jj,1,jpatch)  * i%XDG (jj,1,jpatch) 
          pwg(jj,2)  = pwg(jj,2)  + i%XPATCH(jj,jpatch) * i%XWG(jj,2,jpatch)  * i%XDG (jj,2,jpatch) 
          pwg(jj,3)  = pwg(jj,3)  + i%XPATCH(jj,jpatch) * i%XWG(jj,3,jpatch)  * zwork
          pwgi(jj,1) = pwgi(jj,1) + i%XPATCH(jj,jpatch) * i%XWGI(jj,1,jpatch) * i%XDG (jj,1,jpatch) 
          pwgi(jj,2) = pwgi(jj,2) + i%XPATCH(jj,jpatch) * i%XWGI(jj,2,jpatch) * i%XDG (jj,2,jpatch) 
          pwgi(jj,3) = pwgi(jj,3) + i%XPATCH(jj,jpatch) * i%XWGI(jj,3,jpatch) * zwork
          ! 
          pdg(jj,1) = pdg(jj,1) + i%XPATCH(jj,jpatch) * i%XDG(jj,1,jpatch)
          pdg(jj,2) = pdg(jj,2) + i%XPATCH(jj,jpatch) * i%XDG (jj,2,jpatch)
          pdg(jj,3) = pdg(jj,3) + i%XPATCH(jj,jpatch) * i%XDG (jj,3,jpatch)
          !
!          
       ENDIF
     ENDDO
  ENDDO     
!     
 WHERE (pdg(:,1)>0.0)
    pwg(:,1)  = pwg(:,1)  / pdg(:,1)
    pwgi(:,1)  = pwgi(:,1)  / pdg(:,1)
 ENDWHERE
 WHERE (pdg(:,2)>0.0)
    pwg(:,2)  = pwg(:,2)  / pdg(:,2)
    pwgi(:,2)  = pwgi(:,2)  / pdg(:,2)
 ENDWHERE
 WHERE (pdg(:,3)-pdg(:,2)>0.0)
    pwg(:,3)  = pwg(:,3)  / (pdg(:,3)-pdg(:,2))
    pwgi(:,3)  = pwgi(:,3)  / (pdg(:,3)-pdg(:,2))
 ENDWHERE
ELSE
    pwg(:,:)  = i%XWG(:,:,1)
    pwgi(:,:) = i%XWGI(:,:,1)
    pdg(:,:) = i%XDG (:,:,1)

ENDIF 
!

IF (lhook) CALL dr_hook('AVG_PATCH_WG',1,zhook_handle)

END SUBROUTINE avg_patch_wg