irrigation_update.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 irrigation_update (AG, &
                                    pirrig, ptstep, kmonth, kday,   &
       ptime,tseedmonth,tseedday,treapmonth,treapday) 
!     ####################################################################
!
!!****  *IRRIGATION_UPDATE* - routine to update irrigation fields
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      P. Le Moigne  *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    06/2006
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
!
USE modd_agri_n, ONLY : agri_t
!
USE modd_agri,   ONLY   : jpstage, xthreshold
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
TYPE(agri_t), INTENT(INOUT) :: ag
!
INTEGER, DIMENSION(:,:), INTENT(IN) :: tseedmonth
INTEGER, DIMENSION(:,:), INTENT(IN) :: tseedday
INTEGER, DIMENSION(:,:), INTENT(IN) :: treapmonth
INTEGER, DIMENSION(:,:), INTENT(IN) :: treapday
REAL   , DIMENSION(:,:), INTENT(IN) :: pirrig
REAL,    INTENT(IN)  :: ptstep, ptime
INTEGER, INTENT(IN)  :: kmonth, kday
INTEGER              :: il, jl                        
LOGICAL              :: gmask
REAL(KIND=JPRB) :: zhook_handle
!
!*       0.1   Declarations of arguments
!-------------------------------------------------------------------------------
!
! Mask to realize update only once a day
!
IF (lhook) CALL dr_hook('MODI_IRRIGATION_UPDATE:IRRIGATION_UPDATE',0,zhook_handle)
gmask = ( ptime - ptstep < 0. ) .AND. ( ptime >= 0. )
!
IF (gmask) THEN

   WHERE( (pirrig(:,:).GT.0.).AND.(ag%LIRRIDAY(:,:)) .AND.(ag%NIRRINUM(:,:).LT.jpstage))
      ag%NIRRINUM (:,:) = ag%NIRRINUM(:,:) + 1
      ag%LIRRIDAY (:,:) = .false.
   ENDWHERE
!   
   DO il=1,SIZE(pirrig,1)
       DO jl=1,SIZE(pirrig,2)
           ag%XTHRESHOLDSPT(il,jl)=xthreshold(ag%NIRRINUM(il,jl))
       ENDDO
   ENDDO
!
END IF
!
! Reinitialization of irrigation stage (necessary for runs from August to August)
!
IF((kmonth==1).AND.(kday==1)) THEN
   ag%NIRRINUM(:,:) = 1
ENDIF
!
ag%LIRRIGATE(:,:) = .false.
DO il=1,SIZE(pirrig,1)
   DO jl=1,SIZE(pirrig,2)
      !
      ! Activate irrigation after seeding date
      !
      IF (kmonth == tseedmonth(il,jl) .AND. kday .GE. tseedday(il,jl)) THEN
         ag%LIRRIGATE(il,jl) = .true.
      END IF
      IF (kmonth > tseedmonth(il,jl)) THEN
         ag%LIRRIGATE(il,jl) = .true.
      END IF
      !
      ! Stop irrigation after reaping date
      !
      IF (kmonth == treapmonth(il,jl) .AND. kday .GT. treapday(il,jl)) THEN
         ag%LIRRIGATE(il,jl) = .false.
      END IF
      IF (kmonth > treapmonth(il,jl)) THEN
         ag%LIRRIGATE(il,jl) = .false.
      END IF
   ENDDO
ENDDO
IF (lhook) CALL dr_hook('MODI_IRRIGATION_UPDATE:IRRIGATION_UPDATE',1,zhook_handle)
!
END SUBROUTINE irrigation_update