assim_sean.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_sea_n (S, U, &
                        hprogram,ki,pts_in,psst_in,psic_in,pitm,htest, &
                       olkeepextzone,od_maskext,plon_in,plat_in)

!     ###############################################################################
!
!!****  *ASSIM_SEA_n * - Chooses the surface assimilation schemes for SEA tile
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     T. Aspelien
!!
!!    MODIFICATIONS
!!    -------------
!!      Original       04/2012
!!      Trygve Aspelien, Separating IO  06/2013 
!!--------------------------------------------------------------------
!
!
USE modd_seaflux_n, ONLY : seaflux_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surfex_mpi, ONLY : nrank, npio
!
USE modd_surf_par,       ONLY : xundef
USE modd_assim,          ONLY : nprintlev,laesst,lextrap_sea
!
!
USE yomhook,             ONLY : lhook,dr_hook
USE parkind1,            ONLY : jprb
!
USE modi_abor1_sfx
USE modi_pack_same_rank
USE modi_oi_hor_extrapol_surf
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
TYPE(seaflux_t), INTENT(INOUT) :: s
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 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) :: psst_in
REAL,DIMENSION(KI), INTENT(IN) :: psic_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) :: zalt
REAL, DIMENSION(KI) :: zsst
REAL, DIMENSION(KI) :: zsst0
REAL, DIMENSION(KI) :: zsstinc
REAL, DIMENSION(:), ALLOCATABLE :: zsst01, zsst1, zlon1, zlat1, zalt1 
REAL :: zfmax, zfmin, zfmean
LOGICAL, DIMENSION(KI) :: ginterp_sst
LOGICAL, DIMENSION(:), ALLOCATABLE :: ginterp_sst1
INTEGER  :: iresp, i, j, j1, is1
REAL(KIND=JPRB) :: zhook_handle

IF (lhook) CALL dr_hook('ASSIM_SEA_N',0,zhook_handle)
!
IF (htest/='OK') THEN
  CALL abor1_sfx('ASSIM_SEA_n: FATAL ERROR DURING ARGUMENT TRANSFER')
END IF
!
IF (nrank==npio) WRITE(*,*) 'UPDATING SST FOR SCHEME: ',trim(u%CSEA)
IF (u%CSEA=="NONE") THEN
  IF (lhook) CALL dr_hook('ASSIM_SEA_N',1,zhook_handle)
  RETURN
ENDIF
!
 CALL pack_same_rank(u%NR_SEA,u%XZS,zalt)
!
! Read SST from file or set it to input SST
IF ( .NOT.laesst ) THEN
  ! Set SST to input
  zsst(:) = psst_in(:)
  !
ELSE
  ! SST analysed in CANARI 
  zsst(:) = xundef
  DO i=1,ki
    IF (pitm(i)<0.5 .AND. u%XSEA(u%NR_SEA(i))/=0. ) THEN
     zsst(i) = pts_in(i)   ! set SST analysis from CANARI
    ENDIF
  END DO
  !
  zfmin = minval(zsst)
  zfmax = maxval(zsst)
  zfmean = sum(zsst)/float(ki)
  WRITE(*,*) '  SST analysis from CANARI '
  WRITE(*,'("  ZSST            - min, mean, max: ",3E13.4)') zfmin, zfmean, zfmax
ENDIF
!*     PSST updated at all sea points with ZSST where ZSST is available
ginterp_sst(:) = .false.
! Set SST from watfluxn
DO i=1,ki
  !
  IF ( zsst(i)/=xundef ) THEN
    zsst0(i) = zsst(i)
  ELSEIF ( lextrap_sea ) THEN
    zsst0(i) = xundef
    ginterp_sst(i) = .true.
  ELSE
    zsst0(i) = s%XSST(i)
  ENDIF
  !
ENDDO
!
IF ( lextrap_sea ) THEN
  !
  IF (olkeepextzone) THEN
    !     
    zsst(:) = zsst0(:)
    WHERE ( od_maskext(:) ) zsst0(:) = xundef
    CALL oi_hor_extrapol_surf(ki,plat_in,plon_in,zsst0,plat_in,plon_in,zsst,ginterp_sst,zalt)
    !
  ELSE
    !
    is1 = count(.NOT. od_maskext)
    ALLOCATE (zsst1(is1), zsst01(is1), zlat1(is1), zlon1(is1), zalt1(is1), ginterp_sst1(is1))
    !
    ! remove extension zone
    j = 1
    DO j1 = 1, ki
      IF (.NOT. od_maskext(j1)) THEN
        zsst01(j) = zsst0(j1)
        zlat1(j) = plat_in(j1)
        zlon1(j) = plon_in(j1)
        zalt1(j) = u%XZS  (j1)
        ginterp_sst1(j) = ginterp_sst(j1)
        j = j + 1
      ENDIF
    ENDDO
      
    zsst1(:) = zsst01(:)
    CALL oi_hor_extrapol_surf(is1,zlat1,zlon1,zsst01,zlat1,zlon1,zsst1,ginterp_sst1,zalt1)
 
    ! copy back
    j = 1
    DO j1 = 1, ki
      IF (.NOT. od_maskext(j1)) THEN
        zsst(j1) = zsst1(j)
        j = j + 1
      ENDIF
    ENDDO
    !
    DEALLOCATE (zsst01, zsst1, zlat1, zlon1, zalt1, ginterp_sst1)
    !
  ENDIF
  !
ENDIF
!
!*     Print values produced by OI_HO_EXTRAPOL_SURF
IF ( nprintlev > 2 ) THEN
  DO i=1,ki
    IF (ginterp_sst(i)) THEN
      print *,'Sea surface temperature set to ',zsst(i),'from nearest neighbour at I=',u%NR_SEA(i)
    ENDIF
  ENDDO
ENDIF
!
! Sum the increments
zsstinc(:) = zsst(:) - s%XSST(:)
IF (ki>0) WRITE(*,*) 'Mean SST increments over SEA   ',sum(zsstinc)/ki
!
! Setting modified variables
s%XSST(:) = zsst(:)
!
IF (lhook) CALL dr_hook('ASSIM_SEA_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!
END SUBROUTINE assim_sea_n