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 (IO, NP, NPE, 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_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_np_t, isba_npe_t, isba_p_t, isba_pe_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_options_t), INTENT(IN) :: IO
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
 REAL, DIMENSION(:,:), INTENT(OUT) :: PWG
 REAL, DIMENSION(:,:), INTENT(OUT) :: PWGI
 REAL, DIMENSION(:,:), INTENT(OUT) :: PDG
!      
!*      0.2    declarations of local variables
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
 INTEGER                         :: JI, JP ! loop indexes
 INTEGER                         :: IMASK
 REAL                            :: ZWORK 
REAL, DIMENSION(SIZE(PWG,1)) :: ZSUMPATCH
 !
 REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('AVG_PATCH_WG',0,zhook_handle)
!
zsumpatch(:) = 0.0
DO jp=1,io%NPATCH
  DO ji=1,np%AL(jp)%NSIZE_P
    imask = np%AL(jp)%NR_P(ji)
    zsumpatch(imask) = zsumpatch(imask) + np%AL(jp)%XPATCH(ji)
  END DO
END DO

pwg(:,:) =0.0
pwgi(:,:)=0.0
pdg(:,:) =0.0
!
! 
IF (io%NPATCH/=1)THEN
  DO jp=1,io%NPATCH
    pk => np%AL(jp)
    pek => npe%AL(jp)
    DO ji=1,pk%NSIZE_P
      imask = pk%NR_P(ji) 
      IF(zsumpatch(imask) > 0.)THEN
        !
        zwork=max(0.0,pk%XDG(ji,3)-pk%XDG(ji,2))
        pwg(imask,1)  = pwg(imask,1)  + pk%XPATCH(ji) * pek%XWG(ji,1)  * pk%XDG (ji,1) 
        pwg(imask,2)  = pwg(imask,2)  + pk%XPATCH(ji) * pek%XWG(ji,2)  * pk%XDG (ji,2) 
        pwg(imask,3)  = pwg(imask,3)  + pk%XPATCH(ji) * pek%XWG(ji,3)  * zwork
        pwgi(imask,1) = pwgi(imask,1) + pk%XPATCH(ji) * pek%XWGI(ji,1) * pk%XDG (ji,1) 
        pwgi(imask,2) = pwgi(imask,2) + pk%XPATCH(ji) * pek%XWGI(ji,2) * pk%XDG (ji,2) 
        pwgi(imask,3) = pwgi(imask,3) + pk%XPATCH(ji) * pek%XWGI(ji,3) * zwork
        ! 
        pdg(imask,1) = pdg(imask,1) + pk%XPATCH(ji) * pk%XDG(ji,1)
        pdg(imask,2) = pdg(imask,2) + pk%XPATCH(ji) * pk%XDG(ji,2)
        pdg(imask,3) = pdg(imask,3) + pk%XPATCH(ji) * pk%XDG(ji,3)
        !          
      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

  DO jp=1,io%NPATCH
    DO ji=1,np%AL(jp)%NSIZE_P
       imask = np%AL(jp)%NR_P(ji)         
       pwg(imask,:) = npe%AL(1)%XWG (ji,:)
       pwgi(imask,:) = npe%AL(1)%XWGI(ji,:)
       pdg(imask,:) = np%AL (1)%XDG (ji,:)
     ENDDO
  ENDDO

ENDIF 
!

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

END SUBROUTINE avg_patch_wg