source: LMDZ6/branches/IPSLCM6.0.14/libf/phylmd/Dust/bl_for_dms.F @ 5342

Last change on this file since 5342 was 2630, checked in by fhourdin, 8 years ago

Importation du modèle d'aérosols de Boucher, Escribano et al.

File size: 3.7 KB
Line 
1      SUBROUTINE bl_for_dms(u,v,paprs,pplay,cdragh,cdragm
2     .                     ,t,q,tsol,ustar,obklen)
3      USE dimphy
4      IMPLICIT NONE
5c
6c===================================================================
7c Auteur : E. Cosme
8c Calcul de la vitesse de friction (ustar) et de la longueur de
9c Monin-Obukhov (obklen), necessaires pour calculer les flux de DMS
10c par la methode de Nightingale.
11c Cette subroutine est plus que fortement inspiree de la subroutine
12c 'nonlocal' dans clmain.F .
13c reference :  Holtslag, A.A.M., and B.A. Boville, 1993:
14c Local versus nonlocal boundary-layer diffusion in a global climate
15c model. J. of Climate, vol. 6, 1825-1842. (a confirmer)
16c 31 08 01
17c===================================================================
18c
19#include "dimensions.h"
20#include "YOMCST.h"
21#include "YOETHF.h"
22#include "FCTTRE.h"
23c
24c Arguments :
25      REAL u(klon,klev)          ! vent zonal
26      REAL v(klon,klev)          ! vent meridien
27      REAL paprs(klon,klev+1)    ! niveaux de pression aux intercouches (Pa)
28      REAL pplay(klon,klev)      ! niveaux de pression aux milieux... (Pa)
29      REAL cdragh(klon)          ! coefficient de trainee pour la chaleur
30      REAL cdragm(klon)          ! coefficient de trainee pour le vent
31      REAL t(klon,klev)          ! temperature
32      REAL q(klon,klev)          ! humidite kg/kg
33      REAL tsol(klon)            ! temperature du sol
34      REAL ustar(klon)           ! vitesse de friction
35      REAL obklen(klon)          ! longueur de Monin-Obukhov
36c
37c Locales :
38      REAL vk
39      PARAMETER (vk=0.35)
40      REAL beta  ! coefficient d'evaporation reelle (/evapotranspiration)
41                 ! entre 0 et 1, mais 1 au-dessus de la mer
42      PARAMETER (beta=1.)
43      INTEGER i,k
44      REAL zxt, zxu, zxv, zxq, zxqs, zxmod, taux, tauy
45      REAL zcor, zdelta, zcvm5
46      REAL z(klon,klev)
47      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
48      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
49      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
50      REAL heatv(klon)      ! surface virtual heat flux
51
52     
53c
54c======================================================================
55c
56c Calculer les hauteurs de chaque couche
57c
58! JE20150707      r2es=611.14 *18.0153/28.9644
59      DO i = 1, klon
60         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
61     .               * (paprs(i,1)-pplay(i,1)) / RG
62      ENDDO
63      DO k = 2, klev
64      DO i = 1, klon
65         z(i,k) = z(i,k-1)
66     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
67     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
68      ENDDO
69      ENDDO
70
71      DO i = 1, klon
72c
73        zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
74        zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
75        zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
76        zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
77        zxqs=MIN(0.5,zxqs)
78        zcor=1./(1.-retv*zxqs)
79        zxqs=zxqs*zcor
80c
81        zx_alf1 = 1.0
82        zx_alf2 = 1.0 - zx_alf1
83        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
84     .        *(1.+RETV*q(i,1))*zx_alf1
85     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
86     .        *(1.+RETV*q(i,2))*zx_alf2
87        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
88        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
89        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
90        zxmod = 1.0+SQRT(zxu**2+zxv**2)
91        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cdragh(i)
92        kqfs(i) = (zxqs-zxq) *zxmod*cdragh(i) * beta
93        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
94        taux = zxu *zxmod*cdragm(i)
95        tauy = zxv *zxmod*cdragm(i)
96        ustar(i) = SQRT(taux**2+tauy**2)
97        ustar(i) = MAX(SQRT(ustar(i)),0.01)
98c
99      ENDDO
100c
101      DO i = 1, klon
102         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
103      ENDDO
104c
105      END SUBROUTINE
Note: See TracBrowser for help on using the repository browser.