put_sfx_sea.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 put_sfx_sea (S, U, W, &
                              kluout,ocpl_seaice,owater,psea_sst,psea_ucu,        &
                             psea_vcu,pseaice_sit,pseaice_cvr,pseaice_alb )  
!     ####################################################
!
!!****  *PUT_SFX_SEA* - routine to put some variables from
!!                       an oceanic general circulation model
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      B. Decharme      *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    08/2009
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
!
USE modd_seaflux_n, ONLY : seaflux_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_watflux_n, ONLY : watflux_t
!
USE modd_surf_par,   ONLY : xundef
USE modd_csts,       ONLY : xtt, xtts, xicec
!
!
USE modi_pack_same_rank
USE modi_abor1_sfx
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
!
TYPE(seaflux_t), INTENT(INOUT) :: s
TYPE(surf_atm_t), INTENT(INOUT) :: u
TYPE(watflux_t), INTENT(INOUT) :: w
!
INTEGER,           INTENT(IN)  :: kluout
LOGICAL,           INTENT(IN)  :: ocpl_seaice
LOGICAL,           INTENT(IN)  :: owater
!
REAL, DIMENSION(:), INTENT(IN) :: psea_sst
REAL, DIMENSION(:), INTENT(IN) :: psea_ucu
REAL, DIMENSION(:), INTENT(IN) :: psea_vcu
REAL, DIMENSION(:), INTENT(IN) :: pseaice_sit
REAL, DIMENSION(:), INTENT(IN) :: pseaice_cvr
REAL, DIMENSION(:), INTENT(IN) :: pseaice_alb
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
!
 CHARACTER(LEN=50)     :: ycomment
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA',0,zhook_handle)
!
!*       1.0   Initialization
!              --------------
!
!
!*       2.0   Get variable over sea
!              ---------------------
!
IF(u%NSIZE_SEA>0)THEN
! 
  CALL treat_sea(u%NSIZE_SEA)
!
ENDIF
!
!*       3.0   Get variable over water without flake
!              -------------------------------------
!
IF(owater.AND.u%NSIZE_WATER>0)THEN
!
  CALL treat_water(u%NSIZE_WATER)
!
ENDIF
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA',1,zhook_handle)
!
!-------------------------------------------------------------------------------
 CONTAINS
!-------------------------------------------------------------------------------
!
SUBROUTINE treat_sea(KLU)
!
USE modi_pack_same_rank
!
IMPLICIT NONE
!
INTEGER,     INTENT(IN) :: klu
!
REAL,    DIMENSION(KLU) :: zsst     ! sea surface temperature
REAL,    DIMENSION(KLU) :: zice_frac! ice fraction
REAL                    :: ztmin    ! Minimum temperature over this proc
REAL                    :: ztmax    ! Maximum temperature over this proc
 CHARACTER(LEN=50)       :: ycomment
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:TREAT_SEA',0,zhook_handle)
!
ycomment='Sea surface temperature'
 CALL pack_same_rank(u%NR_SEA(:),psea_sst(:),zsst(:))
WHERE (zsst(:)/=0.0) s%XSST(:)=zsst(:)
 CALL check_sea(ycomment,s%XSST(:))
!
ztmin=minval(s%XSST(:))
ztmax=maxval(s%XSST(:))
!
IF(ztmin<=0.0.OR.ztmax>500.)THEN
  WRITE(kluout,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  WRITE(kluout,*)'SST from ocean model not define or not physic'
  WRITE(kluout,*)'SST MIN =',ztmin,'SST MAX =',ztmax
  WRITE(kluout,*)'There is certainly a problem between         '
  WRITE(kluout,*)'SURFEX and OASIS sea/land mask               '
  WRITE(kluout,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  CALL abor1_sfx('PUT_SFX_SEA: SST from ocean model not define or not physic')
ENDIF
!
ycomment='Sea u-current stress'
 CALL pack_same_rank(u%NR_SEA(:),psea_ucu(:),s%XUMER(:))
 CALL check_sea(ycomment,s%XUMER(:))
!
ycomment='Sea v-current stress'
 CALL pack_same_rank(u%NR_SEA(:),psea_vcu(:),s%XVMER(:))
 CALL check_sea(ycomment,s%XVMER(:))
!
IF(ocpl_seaice)THEN
!
  ycomment='Sea-ice Temperature'
  CALL pack_same_rank(u%NR_SEA(:),pseaice_sit(:),s%XTICE(:))
  CALL check_sea(ycomment,s%XTICE(:))
!
  ycomment='Sea-ice cover'
  CALL pack_same_rank(u%NR_SEA(:),pseaice_cvr(:),zice_frac(:))
  CALL check_sea(ycomment,zice_frac(:))
!
  WHERE(zice_frac(:)>=xicec)
    s%XSST(:) = min(s%XSST(:),xtts-0.01)
  ELSEWHERE
    s%XSST(:) = max(s%XSST(:),xtts)
  ENDWHERE
!
  ycomment='Sea-ice albedo'
  CALL pack_same_rank(u%NR_SEA(:),pseaice_alb(:),s%XICE_ALB(:))
  CALL check_sea(ycomment,s%XICE_ALB(:))
!
! Fill the table with sea ice albedo where temperature is lower than the
! freezing point
  WHERE(s%XSST(:) < xtts)
    s%XDIR_ALB(:)=s%XICE_ALB(:)
    s%XSCA_ALB(:)=s%XICE_ALB(:)
  ENDWHERE
!
ENDIF
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:TREAT_SEA',1,zhook_handle)
!
END SUBROUTINE treat_sea
!
!-------------------------------------------------------------------------------
!
SUBROUTINE treat_water(KLU)
!
!
IMPLICIT NONE
!
INTEGER,     INTENT(IN) :: klu
!
REAL,    DIMENSION(KLU) :: zice_frac! ice fraction
REAL                    :: ztmin    ! Minimum temperature over this proc
REAL                    :: ztmax    ! Maximum temperature over this proc
 CHARACTER(LEN=50)       :: ycomment
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:TREAT_WATER',0,zhook_handle)
!
ycomment='Water surface temperature'
 CALL pack_same_rank(u%NR_WATER(:),psea_sst(:),w%XTS(:))
 CALL check_sea(ycomment,w%XTS(:))
!
ztmin=minval(w%XTS(:))
ztmax=maxval(w%XTS(:))
!
IF(ztmin<=0.0.OR.ztmax>500.)THEN
  WRITE(kluout,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  WRITE(kluout,*)'TS_WATER from ocean model not define or not physic'
  WRITE(kluout,*)'TS_WATER MIN =',ztmin,'TS_WATER MAX =',ztmax
  WRITE(kluout,*)'There is certainly a problem between              '
  WRITE(kluout,*)'SURFEX and OASIS sea/land mask                    '
  WRITE(kluout,*)'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  CALL abor1_sfx('PUT_SFX_SEA: SST from ocean model not define or not physic')
ENDIF
!
ycomment='Water-ice Temperature'
 CALL pack_same_rank(u%NR_WATER(:),pseaice_sit(:),w%XTICE(:))
 CALL check_sea(ycomment,w%XTICE(:))
!
ycomment='Water-ice cover'
 CALL pack_same_rank(u%NR_WATER(:),pseaice_cvr(:),zice_frac(:))
 CALL check_sea(ycomment,zice_frac(:))
!
WHERE(zice_frac(:)>=xicec)
  w%XTS(:) = min(w%XTS(:),xtt-0.01)
ELSEWHERE
  w%XTS(:) = max(w%XTS(:),xtt)
ENDWHERE
!
ycomment='Water-ice albedo'
 CALL pack_same_rank(u%NR_WATER(:),pseaice_alb(:),w%XICE_ALB(:))
 CALL check_sea(ycomment,w%XICE_ALB(:))
!
! Fill the table with sea ice albedo where temperature is lower than the freezing
! point
WHERE(w%XTS(:) < xtt)
  w%XDIR_ALB(:)=w%XICE_ALB(:)
  w%XSCA_ALB(:)=w%XICE_ALB(:)
ENDWHERE
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:TREAT_WATER',1,zhook_handle)
!
END SUBROUTINE treat_water
!
!-------------------------------------------------------------------------------
!
SUBROUTINE check_sea(HCOMMENT,PFIELD)
!
IMPLICIT NONE
!
 CHARACTER(LEN=*),   INTENT(IN) :: hcomment
REAL, DIMENSION(:), INTENT(IN) :: pfield
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:CHECK_SEA',0,zhook_handle)
!
IF(any(pfield(:)>=xundef))THEN
  WRITE(kluout,*)'PUT_SFX_SEA: problem after get '//trim(hcomment)//' from OASIS'
  WRITE(kluout,*)'PUT_SFX_SEA: some points not defined = ',count(pfield(:)>=xundef)
  CALL abor1_sfx('PUT_SFX_SEA: problem after get '//trim(hcomment)//' from OASIS')          
ENDIF
!
IF (lhook) CALL dr_hook('PUT_SFX_SEA:CHECK_SEA',1,zhook_handle)
!
END SUBROUTINE check_sea
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE put_sfx_sea