dispatch_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 dispatch_wg (S, NP, NPE, PWG, PWGI, PDG)
!     ##########################
!
!!
!!    PURPOSE
!!    -------
!      from  AVERAGE_DIAG_MISC_ISBA_n
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    none
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!
!!       ELYAZIDI/HEYMES/RISTOR * Meteo-France *
!!
!!    MODIFICATIONS
!!    -------------
!!
!!      Original  02/2011 
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
!
USE modd_isba_n, ONLY : isba_s_t, isba_np_t, isba_npe_t
!
USE modd_surf_par,  ONLY : xundef, nundef
USE modd_isba_par,      ONLY : xwgmin
USE modd_coupling_topd, ONLY :  xatop
!
USE yomhook   ,     ONLY : lhook,   dr_hook
USE parkind1  ,     ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of argumentsXPATCH
!
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
 REAL, DIMENSION(:,:), INTENT(IN) :: PWG
 REAL, DIMENSION(:,:), INTENT(IN) :: PWGI
 REAL, DIMENSION(:,:), INTENT(IN) :: PDG
!      
!*      0.2    declarations of local variables
 INTEGER                         :: JJ, JLAYER, JPATCH ! loop indexes
 INTEGER                         :: IDEPTH 
 INTEGER                         :: INI, INP
 REAL                            :: ZWORK,ZTMP, ZWORK2
 REAL, DIMENSION(SIZE(S%XPATCH,1)) :: ZSUMPATCH
 REAL, DIMENSION(SIZE(S%XPATCH,1),SIZE(S%XPATCH,2)) :: ZFRAC_PATCH2
 REAL, DIMENSION(SIZE(S%XPATCH,1),SIZE(S%XPATCH,2)) :: ZFRAC_PATCH3
 REAL, DIMENSION(SIZE(PWG,1),SIZE(PWG,2)) :: ZWG_CTL
 !
 INTEGER :: IMASK, JP
 REAL(KIND=JPRB) :: ZHOOK_HANDLE
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('DISPATCH_WG',0,zhook_handle)
!
ini=SIZE(s%XPATCH,1)
inp=SIZE(s%XPATCH,2)
!
 !DO JPATCH=1,INP
 !
 ! write(*,*) 'In dispatch XPATCH (1)',JPATCH,XPATCH(1,JPATCH),XWG(1,2,JPATCH)
 !ENDDO
!write(*,*) 'In dispatch wg ,KI,INI,INP ',KI,INI,INP
IF (inp/=1)THEN
 DO jp=1,inp
   DO jj=1,np%AL(jp)%NSIZE_P
     imask = np%AL(jp)%NR_P(jj)
     IF ((s%XPATCH(imask,jp)/=xundef).AND.(s%XPATCH(imask,jp)/=0.).AND.(xatop(imask)==1.)) THEN
       WHERE (npe%AL(jp)%XWG(jj,:)/=xundef)
         npe%AL(jp)%XWG(jj,:) = pwg(imask,:) 
         npe%AL(jp)%XWGI(jj,:)= pwgi(imask,:) 
         np%AL(jp)%XDG(jj,:)  = pdg(imask,:)
       ENDWHERE
     ENDIF
   ENDDO
 ENDDO

ELSE
 DO jp=1,inp
   DO jj=1,np%AL(jp)%NSIZE_P
     imask = np%AL(jp)%NR_P(jj)        
     npe%AL(1)%XWG (jj,:) = pwg(imask,:) 
     npe%AL(1)%XWGI(jj,:) = pwgi(imask,:) 
     np%AL(1)%XDG(jj,:)   = pdg(imask,:)
   ENDDO
 ENDDO
ENDIF
!
DO jp = 1,inp
  WHERE (npe%AL(jp)%XWG(:,:)<xwgmin) 
    npe%AL(jp)%XWG(:,:)=xwgmin
  ENDWHERE
ENDDO
 !     
IF (lhook) CALL dr_hook('DISPATCH_WG',1,zhook_handle)

END SUBROUTINE dispatch_wg