assim_inland_watern.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 assim_inland_water_n (I, U, W, &
                                 hprogram,ki,pts_in,pitm,htest, &
                                olkeepextzone,od_maskext,plon_in,plat_in)

!     ###############################################################################
!
!!****  *ASSIM_INLAND_WATER_n * - Chooses the surface assimilation schemes for INLAND_WATER parts  
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     T. Aspelien
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    04/2012
!!      Trygve Aspelien, Separating IO  06/2013
!!--------------------------------------------------------------------
!
!
USE modd_isba_n, ONLY : isba_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_watflux_n, ONLY : watflux_t
!
USE modd_surfex_mpi, ONLY : nrank, npio
USE modd_surf_par,       ONLY : xundef
USE modd_assim,          ONLY : nprintlev,lextrap_water,lwatertg2
!
USE yomhook,             ONLY : lhook,dr_hook
USE parkind1,            ONLY : jprb
!
USE modi_abor1_sfx
USE modi_oi_hor_extrapol_surf
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(isba_t), INTENT(INOUT) :: i
TYPE(surf_atm_t), INTENT(INOUT) :: u
TYPE(watflux_t), INTENT(INOUT) :: w
!
 CHARACTER(LEN=6),   INTENT(IN) :: hprogram  ! program calling surf. schemes
INTEGER,            INTENT(IN) :: ki
REAL,DIMENSION(KI), INTENT(IN) :: pts_in
REAL,DIMENSION(KI), INTENT(IN) :: pitm
 CHARACTER(LEN=2),   INTENT(IN) :: htest ! must be equal to 'OK'
LOGICAL, INTENT(IN) :: olkeepextzone
LOGICAL, DIMENSION(KI), INTENT(IN) :: od_maskext
REAL(KIND=JPRB), DIMENSION (:), INTENT(IN) ::  plon_in
REAL(KIND=JPRB), DIMENSION (:), INTENT(IN) ::  plat_in
!
!*      0.2    declarations of local variables
!
!-------------------------------------------------------------------------------------
!
REAL, DIMENSION(KI)              :: zlst
REAL, DIMENSION(KI)              :: zlst0
REAL, DIMENSION(KI)              :: zlstinc
REAL, DIMENSION(:), ALLOCATABLE  :: zlst01, zlst1, zlon1, zlat1, zalt1 
!
LOGICAL,DIMENSION(KI) :: ginterp_lst
LOGICAL, DIMENSION(:), ALLOCATABLE :: ginterp_lst1
INTEGER  :: iresp,ji,jj,is1,j1
REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook('ASSIM_INLAND_WATER_N',0,zhook_handle)

IF (htest/='OK') THEN
  CALL abor1_sfx('ASSIM_INLAND_WATER_n: FATAL ERROR DURING ARGUMENT TRANSFER')
END IF

IF (nrank==npio) WRITE(*,*) 'UPDATING LST FOR INLAND_WATER: ',trim(u%CWATER)
IF (u%CWATER=="NONE") THEN
  IF (lhook) CALL dr_hook('ASSIM_INLAND_WATER_N',1,zhook_handle)
  RETURN
ENDIF
!
!*     ZLST updated!
!
zlst(:) = xundef
IF (.NOT.lwatertg2 ) THEN
  !*     ZLST updated from from CANARI analysis
  DO ji=1,ki
    IF ( pitm(ji)<0.5 ) zlst(ji) = pts_in(ji)
  ENDDO
  !
ELSE
  ! Set TG2 from global array
  DO ji=1,ki
    IF ( pitm(ji)>0.5 ) THEN
      !*     ZLST updated from LAND values of climatological TS
      DO jj=1,u%NSIZE_NATURE
        IF ( u%NR_WATER(ji)==u%NR_NATURE(jj) ) THEN
          zlst(ji) = i%XTG(jj,2,1)
          EXIT
        ENDIF
      ENDDO
    ENDIF
  ENDDO
  !
ENDIF
!
! Set local array from global
ginterp_lst(:) = .false.
DO ji=1,ki
  IF ( zlst(ji)/=xundef ) THEN
    zlst0(ji) = zlst(ji)
  ELSEIF ( lextrap_water ) THEN
    ! Keep ZLST or do extrapolation from neighbour points
    zlst0(ji) = xundef
    ginterp_lst(ji) = .true.  
  ELSE
    zlst0(ji) = w%XTS(ji)
  ENDIF
ENDDO
!
IF ( lextrap_water ) THEN
  !
  IF (olkeepextzone) THEN
    !     
    zlst(:) = zlst0(:)
    WHERE ( od_maskext(:) ) zlst0(:) = xundef
    CALL oi_hor_extrapol_surf(ki,plat_in,plon_in,zlst0,plat_in,plon_in,zlst,ginterp_lst,w%XZS)
    !
  ELSE
    !
    is1 = count(.NOT.od_maskext)
    ALLOCATE (zlst1(is1), zlst01(is1), zlat1(is1), zlon1(is1), zalt1(is1), ginterp_lst1(is1))
    !
    ! remove extension zone
    jj = 1
    DO j1 = 1, ki
      IF ( .NOT.od_maskext(j1) )  THEN
        zlst01(jj) = zlst0(j1)
        zlat1(jj) = plat_in(j1)
        zlon1(jj) = plon_in(j1)
        zalt1(jj) = w%XZS  (j1)
        ginterp_lst1(jj) = ginterp_lst(j1)
        jj = jj + 1
      ENDIF
    ENDDO
       
    zlst1(:) = zlst01(:)
    CALL oi_hor_extrapol_surf(is1,zlat1,zlon1,zlst01,zlat1,zlon1,zlst1,ginterp_lst1,zalt1)
    !
    ! copy back
    jj = 1
    DO j1 = 1, ki
      IF ( .NOT.od_maskext(j1) ) THEN
        zlst(j1) = zlst1(jj)
        jj = jj + 1
      ENDIF
    ENDDO
    !
    DEALLOCATE (zlst01, zlst1, zlat1, zlon1, zalt1, ginterp_lst1)
    !
  ENDIF
  !
ENDIF
!
!*     Print values produced by OI_HO_EXTRAPOL_SURF
IF ( nprintlev > 2 ) THEN
  DO ji=1,ki
    IF (ginterp_lst(ji)) THEN
      print *,'Lake surface temperature set to ',zlst(ji),'from nearest neighbour at I=',u%NR_WATER(ji)
    ENDIF
  ENDDO
ENDIF
!
! Sum the increments
IF (all(zlst(:)/=xundef)) THEN
  zlstinc(:) = zlst(:) - w%XTS(:)
  ! Setting modified variables
  w%XTS(:) = zlst(:)
ELSE
  zlstinc(:) = 0.
ENDIF
!
WRITE(*,*) 'Mean LST increments over inland water   ',sum(zlstinc)/ki
!
IF (lhook) CALL dr_hook('ASSIM_INLAND_WATER_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!
END SUBROUTINE assim_inland_water_n