mode_coupling_canopy.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.
!     ######spl
        MODULE mode_coupling_canopy
!     ####################
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
 CONTAINS
!
!     ###############################################################################
SUBROUTINE init_forc( PFORC_U, PDFORC_UDU, PFORC_E, PDFORC_EDE, &
                      pforc_t, pdforc_tdt, pforc_q, pdforc_qdq )
!
IMPLICIT NONE
!
REAL, DIMENSION(:,:), INTENT(OUT) :: pforc_u
REAL, DIMENSION(:,:), INTENT(OUT) :: pdforc_udu
REAL, DIMENSION(:,:), INTENT(OUT) :: pforc_e
REAL, DIMENSION(:,:), INTENT(OUT) :: pdforc_ede
REAL, DIMENSION(:,:), INTENT(OUT) :: pforc_t
REAL, DIMENSION(:,:), INTENT(OUT) :: pdforc_tdt
REAL, DIMENSION(:,:), INTENT(OUT) :: pforc_q
REAL, DIMENSION(:,:), INTENT(OUT) :: pdforc_qdq
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_FORC',0,zhook_handle)
!
pforc_u    = 0.
pdforc_udu = 0.
!
pforc_e(:,:) = 0.
pdforc_ede(:,:) = 0.
!
pforc_t(:,:) = 0.
pdforc_tdt(:,:) = 0.
!
pforc_q(:,:) = 0.
pdforc_qdq(:,:) = 0.
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_FORC',1,zhook_handle)
!
END SUBROUTINE init_forc
!     ###############################################################################
!
!     ###############################################################################
SUBROUTINE init_coupling_canopy( PP, PPA, PT, PQ, PU, PV, PZ, PXU, &
                                 prhoa, palfau, pbetau, palfath,   &
                                 pbetath, palfaq, pbetaq,          &
                                 pppa, ptta, pqqa, puu, pvv,       &
                                 puuref, pzzref,  pexna,           &
                                 ppew_aa_coef, ppew_bb_coef,       &
                                 ppet_aa_coef, ppet_bb_coef,       &
                                 ppeq_aa_coef, ppeq_bb_coef        )
!
USE modd_surf_par,         ONLY : xundef
USE modd_csts,             ONLY : xcpd, xrd, xp00
USE modd_surf_atm,         ONLY : xwindmin
!
IMPLICIT NONE
!
REAL, DIMENSION(:), INTENT(IN) :: pp
REAL, DIMENSION(:), INTENT(IN) :: ppa
REAL, DIMENSION(:), INTENT(IN) :: pt
REAL, DIMENSION(:), INTENT(IN) :: pq
REAL, DIMENSION(:), INTENT(IN) :: pu
REAL, DIMENSION(:), INTENT(IN) :: pv
REAL, DIMENSION(:), INTENT(IN) :: pz
REAL, DIMENSION(:), INTENT(IN) :: pxu
REAL, DIMENSION(:), INTENT(IN) :: prhoa
REAL, DIMENSION(:), INTENT(IN) :: palfau
REAL, DIMENSION(:), INTENT(IN) :: pbetau
REAL, DIMENSION(:), INTENT(IN) :: palfath
REAL, DIMENSION(:), INTENT(IN) :: pbetath
REAL, DIMENSION(:), INTENT(IN) :: palfaq
REAL, DIMENSION(:), INTENT(IN) :: pbetaq
REAL, DIMENSION(:), INTENT(OUT) :: pppa
REAL, DIMENSION(:), INTENT(OUT) :: ptta
REAL, DIMENSION(:), INTENT(OUT) :: pqqa
REAL, DIMENSION(:), INTENT(OUT) :: puu
REAL, DIMENSION(:), INTENT(OUT) :: pvv
REAL, DIMENSION(:), INTENT(OUT) :: puuref
REAL, DIMENSION(:), INTENT(OUT) :: pzzref
REAL, DIMENSION(:), INTENT(OUT) :: pexna
REAL, DIMENSION(:), INTENT(OUT) :: ppew_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppew_bb_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppet_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppet_bb_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppeq_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppeq_bb_coef
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_COUPLING_CANOPY',0,zhook_handle)
!
pppa = pp(:)
ptta = pt(:)
pqqa = pq(:)
puu  = pu / max(sqrt(pu**2+pv**2),xwindmin) * pxu(:)
pvv  = pv / max(sqrt(pu**2+pv**2),xwindmin) * pxu(:)
puuref = pz(:)
pzzref = pz(:)
!
pexna(:)   = (pp(:)/xp00)**(xrd/xcpd)
WHERE (pp(:)==xundef) !* security at first time-step
  pexna = (ppa/xp00)**(xrd/xcpd)
  pppa  = ppa
END WHERE
!
!* ALMA conventions for implicit coefficients:
! U+  = - rho A u'w'  + B
! Th+ = - rho A w'th' + B
! q+  = - rho A w'q'  + B
!
ppew_aa_coef = - palfau / prhoa
ppew_bb_coef = pbetau
ppet_aa_coef = - palfath / prhoa
ppet_bb_coef = pbetath
ppeq_aa_coef = - palfaq / prhoa
ppeq_bb_coef = pbetaq
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_COUPLING_CANOPY',1,zhook_handle)
!
END SUBROUTINE init_coupling_canopy
!     ###############################################################################
!
!     ###############################################################################
SUBROUTINE init_coupling( HCOUPLING,                  &
                          pps, ppa, pta, pqa, pu, pv, &
                          puref, pzref,               &
                          ppew_a_coef, ppew_b_coef,   &
                          ppet_a_coef, ppet_b_coef,   &
                          ppeq_a_coef, ppeq_b_coef,   &
                          pppa, ptta, pqqa, puu, pvv, &
                          puuref, pzzref,             &
                          ppew_aa_coef, ppew_bb_coef, &
                          ppet_aa_coef, ppet_bb_coef, &
                          ppeq_aa_coef, ppeq_bb_coef  ) 
!
USE modd_csts,             ONLY : xcpd, xrd, xp00
!
IMPLICIT NONE
!
 CHARACTER(LEN=1),   INTENT(IN) :: hcoupling
REAL, DIMENSION(:), INTENT(IN) :: pps
REAL, DIMENSION(:), INTENT(IN) :: ppa
REAL, DIMENSION(:), INTENT(IN) :: pta
REAL, DIMENSION(:), INTENT(IN) :: pqa
REAL, DIMENSION(:), INTENT(IN) :: pu
REAL, DIMENSION(:), INTENT(IN) :: pv
REAL, DIMENSION(:), INTENT(IN) :: puref
REAL, DIMENSION(:), INTENT(IN) :: pzref
REAL, DIMENSION(:), INTENT(IN) :: ppew_a_coef
REAL, DIMENSION(:), INTENT(IN) :: ppew_b_coef
REAL, DIMENSION(:), INTENT(IN) :: ppet_a_coef
REAL, DIMENSION(:), INTENT(IN) :: ppet_b_coef
REAL, DIMENSION(:), INTENT(IN) :: ppeq_a_coef
REAL, DIMENSION(:), INTENT(IN) :: ppeq_b_coef
REAL, DIMENSION(:), INTENT(OUT) :: pppa
REAL, DIMENSION(:), INTENT(OUT) :: ptta
REAL, DIMENSION(:), INTENT(OUT) :: pqqa
REAL, DIMENSION(:), INTENT(OUT) :: puu
REAL, DIMENSION(:), INTENT(OUT) :: pvv
REAL, DIMENSION(:), INTENT(OUT) :: puuref
REAL, DIMENSION(:), INTENT(OUT) :: pzzref
REAL, DIMENSION(:), INTENT(OUT) :: ppew_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppew_bb_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppet_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppet_bb_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppeq_aa_coef
REAL, DIMENSION(:), INTENT(OUT) :: ppeq_bb_coef
!
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_COUPLING',0,zhook_handle)
!
pppa = ppa
ptta = pta
pqqa = pqa
puu  = pu 
pvv  = pv 
puuref = puref
pzzref = pzref
!
ppew_aa_coef = ppew_a_coef
ppew_bb_coef = ppew_b_coef
!
IF (hcoupling=='I') THEN
  ppet_aa_coef = ppet_a_coef
  ppeq_aa_coef = ppeq_a_coef
  ppet_bb_coef = ppet_b_coef
  ppeq_bb_coef = ppeq_b_coef
ELSE
  ppet_aa_coef =  0.
  ppet_bb_coef =  pta / (ppa/xp00)**(xrd/xcpd)
  ppeq_aa_coef =  0.
  ppeq_bb_coef =  pqa
ENDIF
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_COUPLING',1,zhook_handle)
!
END SUBROUTINE init_coupling
!     ###############################################################################
!
!     ###############################################################################
SUBROUTINE init_2m_10m( PP, PT, PQ, PXU, PXZ, PU, PV, PWIND, PRHOA,   &
                        pt2m, pq2m, phu2m, pzon10m, pmer10m,          &
                        pwind10m,  pwind10m_max, pt2m_min, pt2m_max,  &
                        phu2m_min, phu2m_max                          )
!
USE modd_surf_par, ONLY : xundef
!
USE mode_thermos,  ONLY : qsat
!
USE modi_interpol_sbl
!
IMPLICIT NONE
!
REAL, DIMENSION(:), INTENT(IN) :: pp
REAL, DIMENSION(:), INTENT(IN) :: pt
REAL, DIMENSION(:), INTENT(IN) :: pq
REAL, DIMENSION(:,:), INTENT(IN) :: pxu
REAL, DIMENSION(:,:), INTENT(IN) :: pxz
REAL, DIMENSION(:), INTENT(IN) :: pu
REAL, DIMENSION(:), INTENT(IN) :: pv
REAL, DIMENSION(:), INTENT(IN) :: pwind
REAL, DIMENSION(:), INTENT(IN) :: prhoa
REAL, DIMENSION(:), INTENT(OUT) :: pt2m 
REAL, DIMENSION(:), INTENT(OUT) :: pq2m
REAL, DIMENSION(:), INTENT(OUT) :: phu2m
REAL, DIMENSION(:), INTENT(OUT) :: pzon10m
REAL, DIMENSION(:), INTENT(OUT) :: pmer10m
REAL, DIMENSION(:), INTENT(OUT) :: pwind10m
REAL, DIMENSION(:), INTENT(INOUT) :: pwind10m_max
REAL, DIMENSION(:), INTENT(INOUT) :: pt2m_min
REAL, DIMENSION(:), INTENT(INOUT) :: pt2m_max
REAL, DIMENSION(:), INTENT(INOUT) :: phu2m_min
REAL, DIMENSION(:), INTENT(INOUT) :: phu2m_max
!
REAL, DIMENSION(SIZE(PT))   :: zu10
INTEGER                     :: jj
REAL(KIND=JPRB) :: zhook_handle
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_2M_10M',0,zhook_handle)
!
pt2m(:) = pt(:)
pt2m_min(:) = min(pt2m(:),pt2m_min(:))
pt2m_max(:) = max(pt2m(:),pt2m_max(:))
pq2m(:) = pq(:) / prhoa(:)
phu2m(:)= min( pq2m(:) / qsat(pt2m(:),pp(:)) , 1.)
phu2m_min(:) = min(phu2m(:),phu2m_min(:))
phu2m_max(:) = max(phu2m(:),phu2m_max(:))
 CALL interpol_sbl(pxz(:,:),pxu(:,:),10.,zu10(:))
DO jj=1,SIZE(pt)
  IF (zu10(jj)/=xundef) THEN
    IF (pwind(jj)>0.) THEN
      pzon10m(jj) = zu10(jj) * pu(jj)/pwind(jj)
      pmer10m(jj) = zu10(jj) * pv(jj)/pwind(jj)
    ELSE
      pzon10m(jj) = 0.
      pmer10m(jj) = 0.
    END IF
     pwind10m(jj) = sqrt(pzon10m(jj)**2+pmer10m(jj)**2)
     pwind10m_max(jj) = max(pwind10m(jj),pwind10m_max(jj))
  ELSE
    pzon10m(jj) = xundef
    pmer10m(jj) = xundef
    pwind10m(jj) = xundef
    pwind10m_max(jj) = xundef
  END IF
END DO
!
IF (lhook) CALL dr_hook('MODE_COUPLING_CANOPY:INIT_2M_10M',1,zhook_handle)
!
END SUBROUTINE
!
END MODULE mode_coupling_canopy