ecume_seaflux.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 ecume_seaflux(PZ0SEA,PMASK,KSIZE_WATER,KSIZE_ICE,       &
                              pta,pexna,prhoa,psst,psss,pexns,pqa,     &
                              prain,psnow,pvmod,pzref,puref,pps,ppa,   &
                              pichce,oprecip,opwebb,opwg,kz0,          &
                              ohandle_sic,pqsat,psfth,psftq,pustar,pcd,&
                              pcdn,pch,pce,pri,presa,pz0hsea,          &
                              opertflux,ppertflux,hecume               ) 
!     #######################################################################
!
!
!!****  *ECUME_SEAFLUX*  
!!
!!    PURPOSE
!!    -------
!     
!      Calculate the sea surface fluxes with modified bulk algorithm COARE:  
!
!      Calculates the surface fluxes of heat, moisture, and momentum over
!      sea surface with Unified Turbulent fluxes parameterization with calibration 
!      multi-campaign of neutral transfer coefficient from
!      ALBATROS dataset (exp. POMME, CATCH, FETCH, SEMAPHORE, EQUALANT99)
! 
!      based on water_flux computation for sea ice
!     
!!**  METHOD
!!    ------
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------ 
!!      
!!    REFERENCE
!!    ---------
!!     
!!    AUTHOR
!!    ------
!!     C. Lebeaupin  *Météo-France* 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original     18/03/2005
!!      Modified        08/2009 B. Decharme
!!      Modified        01/2014 S. Senesi : handle sea ice cover, discard 
!!                                computing fluxes on seaice when done elsewhere
!!      Modified        05/2014 S. Belamari NEW ECUME : Include salinity & atm. pressure impact
!-------------------------------------------------------------------------------
!
!*       0.     DECLARATIONS
!               ------------
USE modd_surf_par,   ONLY : xundef
!!
USE modi_ice_sea_flux
USE modi_ecumev6_flux
USE modi_ecume_flux
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
REAL, DIMENSION(:), INTENT(IN)   :: pmask        ! Either a mask positive for open sea, or a seaice fraction
INTEGER           , INTENT(IN)   :: ksize_water  ! number of points with some sea water 
INTEGER           , INTENT(IN)   :: ksize_ice    ! number of points with some sea ice
!
REAL, DIMENSION(:), INTENT(IN)    :: pta   ! air temperature at atm. level (K)
REAL, DIMENSION(:), INTENT(IN)    :: pqa   ! air humidity at atm. level (kg/kg)
REAL, DIMENSION(:), INTENT(IN)    :: pexna ! Exner function at atm. level
REAL, DIMENSION(:), INTENT(IN)    :: prhoa ! air density at atm. level
REAL, DIMENSION(:), INTENT(IN)    :: pvmod ! module of wind at atm. wind level (m/s)
REAL, DIMENSION(:), INTENT(IN)    :: pzref ! atm. level for temp. and humidity (m)
REAL, DIMENSION(:), INTENT(IN)    :: puref ! atm. level for wind (m)
REAL, DIMENSION(:), INTENT(IN)    :: psst  ! Sea Surface Temperature (K)
REAL, DIMENSION(:), INTENT(IN)    :: psss  ! Sea Surface Salinity (g/kg)
REAL, DIMENSION(:), INTENT(IN)    :: pexns ! Exner function at sea surface
REAL, DIMENSION(:), INTENT(IN)    :: pps   ! air pressure at sea surface (Pa)
REAL, DIMENSION(:), INTENT(IN)    :: ppa   ! air pressure at atm. level (Pa)
REAL, DIMENSION(:), INTENT(IN)    :: prain ! precipitation rate (kg/s/m2)
REAL, DIMENSION(:), INTENT(IN)    :: psnow ! snow rate (kg/s/m2)
REAL, DIMENSION(:), INTENT(IN)    :: ppertflux   ! stochastic flux perturbation pattern
!
REAL,               INTENT(IN)    :: pichce ! 
LOGICAL,            INTENT(IN)    :: oprecip! 
LOGICAL,            INTENT(IN)    :: opwebb ! 
LOGICAL,            INTENT(IN)    :: opwg   ! 
LOGICAL,            INTENT(IN)    :: opertflux !
INTEGER,            INTENT(IN)    :: kz0
LOGICAL,            INTENT(IN)    :: ohandle_sic ! Do we weight seaice and open sea fluxes
 CHARACTER(LEN=6),   INTENT(IN)    :: hecume      ! type of ecume scheme
!
!
REAL, DIMENSION(:), INTENT(INOUT)    :: pz0sea! roughness length over the ocean
!                                                                                 
!  surface fluxes : latent heat, sensible heat, friction fluxes
REAL, DIMENSION(:), INTENT(OUT)      :: psfth ! heat flux (W/m2)
REAL, DIMENSION(:), INTENT(OUT)      :: psftq ! water flux (kg/m2/s)
REAL, DIMENSION(:), INTENT(OUT)      :: pustar! friction velocity (m/s)
!
! diagnostics
REAL, DIMENSION(:), INTENT(OUT)      :: pqsat ! humidity at saturation
REAL, DIMENSION(:), INTENT(OUT)      :: pcd   ! heat drag coefficient
REAL, DIMENSION(:), INTENT(OUT)      :: pcdn  ! momentum drag coefficient
REAL, DIMENSION(:), INTENT(OUT)      :: pch   ! neutral momentum drag coefficient
REAL, DIMENSION(:), INTENT(OUT)      :: pce   !transfer coef. for latent heat flux
REAL, DIMENSION(:), INTENT(OUT)      :: pri   ! Richardson number
REAL, DIMENSION(:), INTENT(OUT)      :: presa ! aerodynamical resistance
REAL, DIMENSION(:), INTENT(OUT)      :: pz0hsea ! heat roughness length
!
!*      0.2    declarations of local variables
!
INTEGER, DIMENSION(KSIZE_WATER) :: ir_water
INTEGER, DIMENSION(KSIZE_ICE)   :: ir_ice
INTEGER                         :: j1,j2,jj
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
!       1.     Create Masks for ice and water sea
!              ------------------------------------
IF (lhook) CALL dr_hook('ECUME_SEAFLUX',0,zhook_handle)
!
ir_water(:)=0
ir_ice(:)=0
j1=0
j2=0
!
IF (ohandle_sic) THEN 
   ! Must compute open sea fluxes even over fully ice-covered sea, which may melt partly
   DO jj=1,SIZE(psst(:))
      ir_water(jj)= jj
   END DO
   ! Do not compute on sea-ice (done in coupling_iceflux)
ELSE
   ! PMASK = XSST -XTTS
   DO jj=1,SIZE(psst(:))
      IF (pmask(jj) >=0.0 ) THEN
         j1 = j1 + 1
         ir_water(j1)= jj
      ELSE
         j2 = j2 + 1
         ir_ice(j2)= jj
      ENDIF
   END DO
ENDIF
!
!-------------------------------------------------------------------------------
!
!       2.      water sea : call to ECUME_FLUX
!              ------------------------------------------------
!
IF (ksize_water > 0 ) CALL treat_surf(ir_water,'W') 
!
!-------------------------------------------------------------------------------
!
!       3.      sea ice : call to ICE_SEA_FLUX
!              ------------------------------------
!
IF ( (ksize_ice > 0 ) .AND. (.NOT. ohandle_sic) ) CALL treat_surf(ir_ice,'I')
!
!
IF (lhook) CALL dr_hook('ECUME_SEAFLUX',1,zhook_handle)
!-------------------------------------------------------------------------------
!
 CONTAINS

SUBROUTINE treat_surf(KMASK,YTYPE)
!
IMPLICIT NONE
!
INTEGER, INTENT(IN), DIMENSION(:) :: kmask
 CHARACTER(LEN=1), INTENT(IN) :: ytype
!
REAL, DIMENSION(SIZE(KMASK))      :: zw_ta   ! air temperature at atm. level (K)
REAL, DIMENSION(SIZE(KMASK))      :: zw_qa   ! air humidity at atm. level (kg/kg)
REAL, DIMENSION(SIZE(KMASK))      :: zw_exna ! Exner function at atm. level
REAL, DIMENSION(SIZE(KMASK))      :: zw_rhoa ! air density at atm. level
REAL, DIMENSION(SIZE(KMASK))      :: zw_vmod ! module of wind at atm. wind level (m/s)
REAL, DIMENSION(SIZE(KMASK))      :: zw_zref ! atm. level for temp. and humidity (m)
REAL, DIMENSION(SIZE(KMASK))      :: zw_uref ! atm. level for wind (m)
REAL, DIMENSION(SIZE(KMASK))      :: zw_sst  ! Sea Surface Temperature (K)
REAL, DIMENSION(SIZE(KMASK))      :: zw_sss  ! Sea Surface Salinity (g/kg)
REAL, DIMENSION(SIZE(KMASK))      :: zw_exns ! Exner function at sea surface
REAL, DIMENSION(SIZE(KMASK))      :: zw_ps   ! air pressure at sea surface (Pa)
REAL, DIMENSION(SIZE(KMASK))      :: zw_pa   ! air pressure at atm. level (Pa)
REAL, DIMENSION(SIZE(KMASK))      :: zw_rain !precipitation rate (kg/s/m2)
REAL, DIMENSION(SIZE(KMASK))      :: zw_snow !snow rate (kg/s/m2)
REAL, DIMENSION(SIZE(KMASK))      :: zw_pertflux !stochastic flux perturbation pattern
!
REAL, DIMENSION(SIZE(KMASK))      :: zw_z0sea! roughness length over the ocean
!                                                                                 
!  surface fluxes : latent heat, sensible heat, friction fluxes
REAL, DIMENSION(SIZE(KMASK))      :: zw_sfth ! heat flux (W/m2)
REAL, DIMENSION(SIZE(KMASK))      :: zw_sftq ! water flux (kg/m2/s)
REAL, DIMENSION(SIZE(KMASK))      :: zw_ustar! friction velocity (m/s)
!
! diagnostics
REAL, DIMENSION(SIZE(KMASK))      :: zw_qsat ! humidity at saturation
REAL, DIMENSION(SIZE(KMASK))      :: zw_cd   ! heat drag coefficient
REAL, DIMENSION(SIZE(KMASK))      :: zw_cdn  ! momentum drag coefficient
REAL, DIMENSION(SIZE(KMASK))      :: zw_ch   ! neutral momentum drag coefficient
REAL, DIMENSION(SIZE(KMASK))      :: zw_ce   !transfer coef. for latent heat flux
REAL, DIMENSION(SIZE(KMASK))      :: zw_ri   ! Richardson number
REAL, DIMENSION(SIZE(KMASK))      :: zw_resa ! aerodynamical resistance
REAL, DIMENSION(SIZE(KMASK))      :: zw_z0hsea ! heat roughness length
REAL ::  zcoeff
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('ECUME_SEAFLUX:TREAT_SURF',0,zhook_handle)
DO jj=1, SIZE(kmask)
  zw_ta(jj)   = pta(kmask(jj))
  zw_qa(jj)   = pqa(kmask(jj))
  zw_exna(jj) = pexna(kmask(jj))
  zw_rhoa(jj) = prhoa(kmask(jj))
  zw_vmod(jj) = pvmod(kmask(jj))
  zw_zref(jj) = pzref(kmask(jj)) 
  zw_uref(jj) = puref(kmask(jj))
  zw_sst(jj)  = psst(kmask(jj))
  zw_sss(jj)  = psss(kmask(jj))
  zw_exns(jj) = pexns(kmask(jj)) 
  zw_ps(jj)   = pps(kmask(jj))
  zw_pa(jj)   = ppa(kmask(jj))
  zw_rain(jj) = prain(kmask(jj))
  zw_snow(jj) = psnow(kmask(jj))
  zw_pertflux(jj) = ppertflux(kmask(jj))
  zw_z0sea(jj)= pz0sea(kmask(jj))
END DO
!
zw_sfth(:)   = xundef
zw_sftq(:)   = xundef
zw_ustar(:)  = xundef
zw_qsat(:)   = xundef
zw_cd(:)     = xundef
zw_cdn(:)    = xundef
zw_ch(:)     = xundef
zw_ce(:)     = xundef
zw_ri(:)     = xundef
zw_resa(:)   = xundef
zw_z0hsea(:) = xundef
!
IF (ytype=='W') THEN
  !
  IF(hecume=='ECUME6')THEN
    !new ecume scheme
    CALL ecumev6_flux(zw_z0sea,zw_ta,zw_exna,zw_rhoa,zw_sst,zw_sss,zw_exns,  &
             zw_qa,zw_vmod,zw_zref,zw_uref,zw_ps,zw_pa,pichce,oprecip,opwebb,&
             zw_qsat,zw_sfth,zw_sftq,zw_ustar,zw_cd,zw_cdn,zw_ch,zw_ce,      &
             zw_ri,zw_resa,zw_rain,kz0,zw_z0hsea,opertflux,zw_pertflux)    
  ELSE
    !old ecume scheme
    CALL ecume_flux(zw_z0sea,zw_ta,zw_exna,zw_rhoa,zw_sst,zw_exns,        &
           zw_qa,zw_vmod,zw_zref,zw_uref,zw_ps,pichce,oprecip,opwebb,opwg,&
           zw_qsat,zw_sfth,zw_sftq,zw_ustar,zw_cd,zw_cdn,zw_ch,zw_ce,     &
           zw_ri,zw_resa,zw_rain,zw_z0hsea,opertflux,zw_pertflux)
  ENDIF
  !
ELSEIF ( (ytype=='I') .AND. (.NOT. ohandle_sic)) THEN
  !
  CALL ice_sea_flux(zw_z0sea,zw_ta,zw_exna,zw_rhoa,zw_sst,zw_exns,zw_qa,zw_rain,zw_snow,  &
          zw_vmod,zw_zref,zw_uref,zw_ps,zw_qsat,zw_sfth,zw_sftq,zw_ustar,zw_cd, &
          zw_cdn,zw_ch,zw_ri,zw_resa,zw_z0hsea)   
  !
ENDIF
!
DO jj=1, SIZE(kmask)
   pqsat(kmask(jj)) =  zw_qsat(jj) 
   pz0sea(kmask(jj))=  zw_z0sea(jj)
   pustar(kmask(jj))=  zw_ustar(jj)
   psfth(kmask(jj)) =  zw_sfth(jj) 
   psftq(kmask(jj)) =  zw_sftq(jj) 
   pcd(kmask(jj))   =  zw_cd(jj) 
   pcdn(kmask(jj))  =  zw_cdn(jj) 
   pch(kmask(jj))   =  zw_ch(jj)
   pce(kmask(jj))   =  zw_ce(jj)
   pri(kmask(jj))   =  zw_ri(jj) 
   presa(kmask(jj)) =  zw_resa(jj) 
   pz0hsea(kmask(jj))= zw_z0hsea(jj) 
END DO
IF (lhook) CALL dr_hook('ECUME_SEAFLUX:TREAT_SURF',1,zhook_handle)
END SUBROUTINE treat_surf
!  
END SUBROUTINE ecume_seaflux