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 (I, &
                              ki,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_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_t), INTENT(INOUT) :: i
!
 INTEGER, INTENT(IN)               :: ki
 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(I%XPATCH,1)) :: zsumpatch
 REAL, DIMENSION(SIZE(I%XPATCH,1),SIZE(I%XPATCH,2)) :: zfrac_patch2
 REAL, DIMENSION(SIZE(I%XPATCH,1),SIZE(I%XPATCH,2)) :: zfrac_patch3
 REAL, DIMENSION(SIZE(PWG,1),SIZE(PWG,2)) :: zwg_ctl
 !
 REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
IF (lhook) CALL dr_hook('DISPATCH_WG',0,zhook_handle)
!
ini=SIZE(i%XPATCH,1)
inp=SIZE(i%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 jpatch=1,inp
   DO jj=1,ini
    IF ((i%XPATCH(jj,jpatch)/=xundef).AND.(i%XPATCH(jj,jpatch)/=0.)&
        .AND.(xatop(jj)==1.)) THEN
     WHERE (i%XWG(jj,:,jpatch)/=xundef)
      i%XWG(jj,:,jpatch) = pwg(jj,:) 
      i%XWGI(jj,:,jpatch)= pwgi(jj,:) 
      i%XDG(jj,:,jpatch) = pdg(jj,:)
     ENDWHERE
    ENDIF
   ENDDO
 ENDDO

ELSE
 i%XWG(:,:,1) = pwg(:,:) 
 i%XWGI(:,:,1)= pwgi(:,:) 
 i%XDG(:,:,1) = pdg(:,:)
ENDIF
!
WHERE (i%XWG(:,:,:)<xwgmin) 
  i%XWG(:,:,:)=xwgmin
ENDWHERE
 !     
IF (lhook) CALL dr_hook('DISPATCH_WG',1,zhook_handle)

END SUBROUTINE dispatch_wg