Context Navigation

pbl_surface_mod.F90 @ 2870

Last change on this file since 2870 was 2870, checked in by Laurent Fairhead, 8 years ago
Merged trunk changes r2842:2865 into testing branch
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 127.3 KB

Line
1	!
2	! $Id: pbl_surface_mod.F90 2870 2017-05-04 07:31:05Z fairhead $
3	!
4	MODULE pbl_surface_mod
5	!
6	! Planetary Boundary Layer and Surface module
7	!
8	! This module manages the calculation of turbulent diffusion in the boundary layer
9	! and all interactions towards the differents sub-surfaces.
10	!
11	!
12	USE dimphy
13	USE mod_phys_lmdz_para, ONLY : mpi_size
14	USE mod_grid_phy_lmdz, ONLY : klon_glo
15	USE ioipsl
16	USE surface_data, ONLY : type_ocean, ok_veget
17	USE surf_land_mod, ONLY : surf_land
18	USE surf_landice_mod, ONLY : surf_landice
19	USE surf_ocean_mod, ONLY : surf_ocean
20	USE surf_seaice_mod, ONLY : surf_seaice
21	USE cpl_mod, ONLY : gath2cpl
22	USE climb_hq_mod, ONLY : climb_hq_down, climb_hq_up
23	USE climb_wind_mod, ONLY : climb_wind_down, climb_wind_up
24	USE coef_diff_turb_mod, ONLY : coef_diff_turb
25
26
27	IMPLICIT NONE
28
29	! Declaration of variables saved in restart file
30	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: fder ! flux drift
31	!$OMP THREADPRIVATE(fder)
32	REAL, ALLOCATABLE, DIMENSION(:,:), PUBLIC, SAVE :: snow ! snow at surface
33	!$OMP THREADPRIVATE(snow)
34	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qsurf ! humidity at surface
35	!$OMP THREADPRIVATE(qsurf)
36	REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature
37	!$OMP THREADPRIVATE(ftsoil)
38
39	CONTAINS
40	!
41	!****************************************************************************************
42	!
43	SUBROUTINE pbl_surface_init(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
44
45	! This routine should be called after the restart file has been read.
46	! This routine initialize the restart variables and does some validation tests
47	! for the index of the different surfaces and tests the choice of type of ocean.
48
49	USE indice_sol_mod
50	USE print_control_mod, ONLY: lunout
51
52	INCLUDE "dimsoil.h"
53
54	! Input variables
55	!****************************************************************************************
56	REAL, DIMENSION(klon), INTENT(IN) :: fder_rst
57	REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: snow_rst
58	REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: qsurf_rst
59	REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst
60
61
62	! Local variables
63	!****************************************************************************************
64	INTEGER :: ierr
65	CHARACTER(len=80) :: abort_message
66	CHARACTER(len = 20) :: modname = 'pbl_surface_init'
67
68
69	!****************************************************************************************
70	! Allocate and initialize module variables with fields read from restart file.
71	!
72	!****************************************************************************************
73	ALLOCATE(fder(klon), stat=ierr)
74	IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1)
75
76	ALLOCATE(snow(klon,nbsrf), stat=ierr)
77	IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1)
78
79	ALLOCATE(qsurf(klon,nbsrf), stat=ierr)
80	IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1)
81
82	ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr)
83	IF (ierr /= 0) CALL abort_physic('pbl_surface_init', 'pb in allocation',1)
84
85
86	fder(:) = fder_rst(:)
87	snow(:,:) = snow_rst(:,:)
88	qsurf(:,:) = qsurf_rst(:,:)
89	ftsoil(:,:,:) = ftsoil_rst(:,:,:)
90
91
92	!****************************************************************************************
93	! Test for sub-surface indices
94	!
95	!****************************************************************************************
96	IF (is_ter /= 1) THEN
97	WRITE(lunout,)" Warning *"
98	WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter
99	WRITE(lunout,*)"or on doit commencer par les surfaces continentales"
100	abort_message="voir ci-dessus"
101	CALL abort_physic(modname,abort_message,1)
102	ENDIF
103
104	IF ( is_oce > is_sic ) THEN
105	WRITE(lunout,)' Warning *'
106	WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
107	WRITE(lunout,*)' l''ocean doit etre traite avant la banquise'
108	WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
109	abort_message='voir ci-dessus'
110	CALL abort_physic(modname,abort_message,1)
111	ENDIF
112
113	IF ( is_lic > is_sic ) THEN
114	WRITE(lunout,)' Warning *'
115	WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
116	WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer'
117	WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic
118	abort_message='voir ci-dessus'
119	CALL abort_physic(modname,abort_message,1)
120	ENDIF
121
122	!****************************************************************************************
123	! Validation of ocean mode
124	!
125	!****************************************************************************************
126
127	IF (type_ocean /= 'slab ' .AND. type_ocean /= 'force ' .AND. type_ocean /= 'couple') THEN
128	WRITE(lunout,)' Warning *'
129	WRITE(lunout,*)'Option couplage pour l''ocean = ', type_ocean
130	abort_message='option pour l''ocean non valable'
131	CALL abort_physic(modname,abort_message,1)
132	ENDIF
133
134	END SUBROUTINE pbl_surface_init
135	!
136	!****************************************************************************************
137	!
138
139	SUBROUTINE pbl_surface( &
140	dtime, date0, itap, jour, &
141	debut, lafin, &
142	rlon, rlat, rugoro, rmu0, &
143	zsig, lwdown_m, pphi, cldt, &
144	rain_f, snow_f, solsw_m, sollw_m, &
145	gustiness, &
146	t, q, u, v, &
147	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
148	!! t_x, q_x, t_w, q_w, &
149	wake_dlt, wake_dlq, &
150	wake_cstar, wake_s, &
151	!!!
152	pplay, paprs, pctsrf, &
153	ts,SFRWL, alb_dir, alb_dif,ustar, u10m, v10m,wstar, &
154	cdragh, cdragm, zu1, zv1, &
155	alb_dir_m, alb_dif_m, zxsens, zxevap, &
156	alb3_lic, runoff, snowhgt, qsnow, to_ice, sissnow, &
157	zxtsol, zxfluxlat, zt2m, qsat2m, &
158	d_t, d_q, d_u, d_v, d_t_diss, &
159	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
160	d_t_w, d_q_w, &
161	d_t_x, d_q_x, &
162	!! d_wake_dlt,d_wake_dlq, &
163	zxsens_x, zxfluxlat_x,zxsens_w,zxfluxlat_w, &
164	!!!
165	!!! nrlmd le 13/06/2011
166	delta_tsurf,wake_dens,cdragh_x,cdragh_w, &
167	cdragm_x,cdragm_w,kh,kh_x,kh_w, &
168	!!!
169	zcoefh, zcoefm, slab_wfbils, &
170	qsol, zq2m, s_pblh, s_plcl, &
171	!!!
172	!!! jyg le 08/02/2012
173	s_pblh_x, s_plcl_x, s_pblh_w, s_plcl_w, &
174	!!!
175	s_capCL, s_oliqCL, s_cteiCL, s_pblT, &
176	s_therm, s_trmb1, s_trmb2, s_trmb3, &
177	zustar,zu10m, zv10m, fder_print, &
178	zxqsurf, rh2m, zxfluxu, zxfluxv, &
179	z0m, z0h, agesno, sollw, solsw, &
180	d_ts, evap, fluxlat, t2m, &
181	wfbils, wfbilo, wfevap, wfrain, wfsnow, &
182	flux_t, flux_u, flux_v, &
183	dflux_t, dflux_q, zxsnow, &
184	!jyg<
185	!! zxfluxt, zxfluxq, q2m, flux_q, tke, &
186	zxfluxt, zxfluxq, q2m, flux_q, tke_x, &
187	!>jyg
188	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
189	!! tke_x, tke_w &
190	wake_dltke &
191	!!!
192	)
193	!****************************************************************************************
194	! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
195	! Objet: interface de "couche limite" (diffusion verticale)
196	!
197	!AA REM:
198	!AA-----
199	!AA Tout ce qui a trait au traceurs est dans phytrac maintenant
200	!AA pour l'instant le calcul de la couche limite pour les traceurs
201	!AA se fait avec cltrac et ne tient pas compte de la differentiation
202	!AA des sous-fraction de sol.
203	!AA REM bis :
204	!AA----------
205	!AA Pour pouvoir extraire les coefficient d'echanges et le vent
206	!AA dans la premiere couche, 3 champs supplementaires ont ete crees
207	!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
208	!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir
209	!AA si les informations des subsurfaces doivent etre prises en compte
210	!AA il faudra sortir ces memes champs en leur ajoutant une dimension,
211	!AA c'est a dire nbsrf (nbre de subsurface).
212	!
213	! Arguments:
214	!
215	! dtime----input-R- interval du temps (secondes)
216	! itap-----input-I- numero du pas de temps
217	! date0----input-R- jour initial
218	! t--------input-R- temperature (K)
219	! q--------input-R- vapeur d'eau (kg/kg)
220	! u--------input-R- vitesse u
221	! v--------input-R- vitesse v
222	! wake_dlt-input-R- temperatre difference between (w) and (x) (K)
223	! wake_dlq-input-R- humidity difference between (w) and (x) (kg/kg)
224	!wake_cstar-input-R- wake gust front speed (m/s)
225	! wake_s---input-R- wake fractionnal area
226	! ts-------input-R- temperature du sol (en Kelvin)
227	! paprs----input-R- pression a intercouche (Pa)
228	! pplay----input-R- pression au milieu de couche (Pa)
229	! rlat-----input-R- latitude en degree
230	! z0m, z0h ----input-R- longeur de rugosite (en m)
231	! Martin
232	! zsig-----input-R- slope
233	! cldt-----input-R- total cloud fraction
234	! pphi-----input-R- geopotentiel de chaque couche (g z) (reference sol)
235	! Martin
236	!
237	! d_t------output-R- le changement pour "t"
238	! d_q------output-R- le changement pour "q"
239	! d_u------output-R- le changement pour "u"
240	! d_v------output-R- le changement pour "v"
241	! d_ts-----output-R- le changement pour "ts"
242	! flux_t---output-R- flux de chaleur sensible (CpT) J/m2/s (W/m2)
243	! (orientation positive vers le bas)
244	! tke_x---input/output-R- tke in the (x) region (kg/m**2/s)
245	! wake_dltke-input/output-R- tke difference between (w) and (x) (kg/m**2/s)
246	! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
247	! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
248	! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
249	! dflux_t--output-R- derive du flux sensible
250	! dflux_q--output-R- derive du flux latent
251	! zu1------output-R- le vent dans la premiere couche
252	! zv1------output-R- le vent dans la premiere couche
253	! trmb1----output-R- deep_cape
254	! trmb2----output-R- inhibition
255	! trmb3----output-R- Point Omega
256	! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL
257	! plcl-----output-R- Niveau de condensation
258	! pblh-----output-R- HCL
259	! pblT-----output-R- T au nveau HCL
260	!
261	USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
262	USE indice_sol_mod
263	USE time_phylmdz_mod, ONLY: day_ini,annee_ref,itau_phy
264	USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat
265	USE print_control_mod, ONLY: prt_level,lunout
266
267	IMPLICIT NONE
268
269	INCLUDE "dimsoil.h"
270	INCLUDE "YOMCST.h"
271	INCLUDE "YOETHF.h"
272	INCLUDE "FCTTRE.h"
273	INCLUDE "clesphys.h"
274	INCLUDE "compbl.h"
275	INCLUDE "flux_arp.h"
276	!****************************************************************************************
277	REAL, INTENT(IN) :: dtime ! time interval (s)
278	REAL, INTENT(IN) :: date0 ! initial day
279	INTEGER, INTENT(IN) :: itap ! time step
280	INTEGER, INTENT(IN) :: jour ! current day of the year
281	LOGICAL, INTENT(IN) :: debut ! true if first run step
282	LOGICAL, INTENT(IN) :: lafin ! true if last run step
283	REAL, DIMENSION(klon), INTENT(IN) :: rlon ! longitudes in degrees
284	REAL, DIMENSION(klon), INTENT(IN) :: rlat ! latitudes in degrees
285	REAL, DIMENSION(klon), INTENT(IN) :: rugoro ! rugosity length
286	REAL, DIMENSION(klon), INTENT(IN) :: rmu0 ! cosine of solar zenith angle
287	REAL, DIMENSION(klon), INTENT(IN) :: rain_f ! rain fall
288	REAL, DIMENSION(klon), INTENT(IN) :: snow_f ! snow fall
289	REAL, DIMENSION(klon), INTENT(IN) :: solsw_m ! net shortwave radiation at mean surface
290	REAL, DIMENSION(klon), INTENT(IN) :: sollw_m ! net longwave radiation at mean surface
291	REAL, DIMENSION(klon,klev), INTENT(IN) :: t ! temperature (K)
292	REAL, DIMENSION(klon,klev), INTENT(IN) :: q ! water vapour (kg/kg)
293	REAL, DIMENSION(klon,klev), INTENT(IN) :: u ! u speed
294	REAL, DIMENSION(klon,klev), INTENT(IN) :: v ! v speed
295	REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay ! mid-layer pression (Pa)
296	REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression between layers (Pa)
297	REAL, DIMENSION(klon, nbsrf), INTENT(IN) :: pctsrf ! sub-surface fraction
298	! Martin
299	REAL, DIMENSION(klon), INTENT(IN) :: zsig ! slope
300	REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downward longwave radiation at mean s
301	REAL, DIMENSION(klon), INTENT(IN) :: gustiness ! gustiness
302
303	REAL, DIMENSION(klon), INTENT(IN) :: cldt ! total cloud fraction
304	REAL, DIMENSION(klon,klev), INTENT(IN) :: pphi ! geopotential (m2/s2)
305	! Martin
306
307	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
308	!! REAL, DIMENSION(klon,klev), INTENT(IN) :: t_x ! Temp\'erature hors poche froide
309	!! REAL, DIMENSION(klon,klev), INTENT(IN) :: t_w ! Temp\'erature dans la poches froide
310	!! REAL, DIMENSION(klon,klev), INTENT(IN) :: q_x !
311	!! REAL, DIMENSION(klon,klev), INTENT(IN) :: q_w ! Pareil pour l'humidit\'e
312	REAL, DIMENSION(klon,klev), INTENT(IN) :: wake_dlt !temperature difference between (w) and (x) (K)
313	REAL, DIMENSION(klon,klev), INTENT(IN) :: wake_dlq !humidity difference between (w) and (x) (K)
314	REAL, DIMENSION(klon), INTENT(IN) :: wake_s ! Fraction de poches froides
315	REAL, DIMENSION(klon), INTENT(IN) :: wake_cstar! Vitesse d'expansion des poches froides
316	REAL, DIMENSION(klon), INTENT(IN) :: wake_dens
317	!!!
318
319	! Input/Output variables
320	!****************************************************************************************
321	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ts ! temperature at surface (K)
322	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: delta_tsurf !surface temperature difference between
323	!wake and off-wake regions
324	!albedo SB >>>
325	REAL, DIMENSIOn(6),intent(in) :: SFRWL
326	REAL, DIMENSION(klon, nsw, nbsrf), INTENT(INOUT) :: alb_dir,alb_dif
327	!albedo SB <<<
328	!jyg Pourquoi ustar et wstar sont-elles INOUT ?
329	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: ustar ! u* (m/s)
330	REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT) :: wstar ! w* (m/s)
331	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: u10m ! u speed at 10m
332	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: v10m ! v speed at 10m
333	!jyg<
334	!! REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: tke
335	REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: tke_x
336	!>jyg
337
338	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
339	REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: wake_dltke ! TKE_w - TKE_x
340	!!!
341
342	! Output variables
343	!****************************************************************************************
344	REAL, DIMENSION(klon), INTENT(OUT) :: cdragh ! drag coefficient for T and Q
345	REAL, DIMENSION(klon), INTENT(OUT) :: cdragm ! drag coefficient for wind
346	REAL, DIMENSION(klon), INTENT(OUT) :: zu1 ! u wind speed in first layer
347	REAL, DIMENSION(klon), INTENT(OUT) :: zv1 ! v wind speed in first layer
348	!albedo SB >>>
349	REAL, DIMENSION(klon, nsw), INTENT(OUT) :: alb_dir_m,alb_dif_m
350	!albedo SB <<<
351	! Martin
352	REAL, DIMENSION(klon), INTENT(OUT) :: alb3_lic
353	! Martin
354	REAL, DIMENSION(klon), INTENT(OUT) :: zxsens ! sensible heat flux at surface with inversed sign
355	! (=> positive sign upwards)
356	REAL, DIMENSION(klon), INTENT(OUT) :: zxevap ! water vapour flux at surface, positiv upwards
357	REAL, DIMENSION(klon), INTENT(OUT) :: zxtsol ! temperature at surface, mean for each grid point
358	!!! jyg le ???
359	REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_w ! !
360	REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_q_w ! ! Tendances dans les poches
361	REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_t_x ! !
362	REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_q_x ! ! Tendances hors des poches
363	!!! jyg
364	REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat ! latent flux, mean for each grid point
365	REAL, DIMENSION(klon), INTENT(OUT) :: zt2m ! temperature at 2m, mean for each grid point
366	REAL, DIMENSION(klon), INTENT(OUT) :: qsat2m
367	REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t ! change in temperature
368	REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_t_diss ! change in temperature
369	REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_q ! change in water vapour
370	REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_u ! change in u speed
371	REAL, DIMENSION(klon, klev), INTENT(OUT) :: d_v ! change in v speed
372
373	REAL, INTENT(OUT):: zcoefh(:, :, :) ! (klon, klev, nbsrf + 1)
374	! coef for turbulent diffusion of T and Q, mean for each grid point
375
376	REAL, INTENT(OUT):: zcoefm(:, :, :) ! (klon, klev, nbsrf + 1)
377	! coef for turbulent diffusion of U and V (?), mean for each grid point
378
379	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
380	REAL, DIMENSION(klon), INTENT(OUT) :: zxsens_x ! Flux sensible hors poche
381	REAL, DIMENSION(klon), INTENT(OUT) :: zxsens_w ! Flux sensible dans la poche
382	REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat_x! Flux latent hors poche
383	REAL, DIMENSION(klon), INTENT(OUT) :: zxfluxlat_w! Flux latent dans la poche
384	!! REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_wake_dlt
385	!! REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_wake_dlq
386
387	! Output only for diagnostics
388	REAL, DIMENSION(klon), INTENT(OUT) :: cdragh_x
389	REAL, DIMENSION(klon), INTENT(OUT) :: cdragh_w
390	REAL, DIMENSION(klon), INTENT(OUT) :: cdragm_x
391	REAL, DIMENSION(klon), INTENT(OUT) :: cdragm_w
392	REAL, DIMENSION(klon), INTENT(OUT) :: kh
393	REAL, DIMENSION(klon), INTENT(OUT) :: kh_x
394	REAL, DIMENSION(klon), INTENT(OUT) :: kh_w
395	!!!
396	REAL, DIMENSION(klon), INTENT(OUT) :: slab_wfbils! heat balance at surface only for slab at ocean points
397	REAL, DIMENSION(klon), INTENT(OUT) :: qsol ! water height in the soil (mm)
398	REAL, DIMENSION(klon), INTENT(OUT) :: zq2m ! water vapour at 2m, mean for each grid point
399	REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh ! height of the planetary boundary layer(HPBL)
400	!!! jyg le 08/02/2012
401	REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh_x ! height of the PBL in the off-wake region
402	REAL, DIMENSION(klon), INTENT(OUT) :: s_pblh_w ! height of the PBL in the wake region
403	!!!
404	REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl ! condensation level
405	!!! jyg le 08/02/2012
406	REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl_x ! condensation level in the off-wake region
407	REAL, DIMENSION(klon), INTENT(OUT) :: s_plcl_w ! condensation level in the wake region
408	!!!
409	REAL, DIMENSION(klon), INTENT(OUT) :: s_capCL ! CAPE of PBL
410	REAL, DIMENSION(klon), INTENT(OUT) :: s_oliqCL ! liquid water intergral of PBL
411	REAL, DIMENSION(klon), INTENT(OUT) :: s_cteiCL ! cloud top instab. crit. of PBL
412	REAL, DIMENSION(klon), INTENT(OUT) :: s_pblT ! temperature at PBLH
413	REAL, DIMENSION(klon), INTENT(OUT) :: s_therm ! thermal virtual temperature excess
414	REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb1 ! deep cape, mean for each grid point
415	REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb2 ! inhibition, mean for each grid point
416	REAL, DIMENSION(klon), INTENT(OUT) :: s_trmb3 ! point Omega, mean for each grid point
417	REAL, DIMENSION(klon), INTENT(OUT) :: zustar ! u*
418	REAL, DIMENSION(klon), INTENT(OUT) :: zu10m ! u speed at 10m, mean for each grid point
419	REAL, DIMENSION(klon), INTENT(OUT) :: zv10m ! v speed at 10m, mean for each grid point
420	REAL, DIMENSION(klon), INTENT(OUT) :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i))
421	REAL, DIMENSION(klon), INTENT(OUT) :: zxqsurf ! humidity at surface, mean for each grid point
422	REAL, DIMENSION(klon), INTENT(OUT) :: rh2m ! relative humidity at 2m
423	REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxu ! u wind tension, mean for each grid point
424	REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxv ! v wind tension, mean for each grid point
425	REAL, DIMENSION(klon, nbsrf+1), INTENT(INOUT) :: z0m,z0h ! rugosity length (m)
426	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: agesno ! age of snow at surface
427	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: solsw ! net shortwave radiation at surface
428	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: sollw ! net longwave radiation at surface
429	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: d_ts ! change in temperature at surface
430	REAL, DIMENSION(klon, nbsrf), INTENT(INOUT) :: evap ! evaporation at surface
431	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: fluxlat ! latent flux
432	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: t2m ! temperature at 2 meter height
433	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbils ! heat balance at surface
434	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfbilo ! water balance at surface weighted by srf
435	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfevap ! water balance (evap) at surface weighted by srf
436	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfrain ! water balance (rain) at surface weighted by srf
437	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: wfsnow ! water balance (snow) at surface weighted by srf
438	REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t ! sensible heat flux (CpT) J/m2/s (W/m2)
439	! positve orientation downwards
440	REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u ! u wind tension (kg m/s)/(m**2 s) or Pascal
441	REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v ! v wind tension (kg m/s)/(m**2 s) or Pascal
442
443	! Output not needed
444	REAL, DIMENSION(klon), INTENT(OUT) :: dflux_t ! change of sensible heat flux
445	REAL, DIMENSION(klon), INTENT(OUT) :: dflux_q ! change of water vapour flux
446	REAL, DIMENSION(klon), INTENT(OUT) :: zxsnow ! snow at surface, mean for each grid point
447	REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxt ! sensible heat flux, mean for each grid point
448	REAL, DIMENSION(klon, klev), INTENT(OUT) :: zxfluxq ! water vapour flux, mean for each grid point
449	REAL, DIMENSION(klon, nbsrf),INTENT(OUT) :: q2m ! water vapour at 2 meter height
450	REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q ! water vapour flux(latent flux) (kg/m**2/s)
451
452	! Martin
453	! sisvat
454	REAL, DIMENSION(klon), INTENT(OUT) :: qsnow ! snow water content
455	REAL, DIMENSION(klon), INTENT(OUT) :: snowhgt ! snow height
456	REAL, DIMENSION(klon), INTENT(OUT) :: to_ice ! snow passed to ice
457	REAL, DIMENSION(klon), INTENT(OUT) :: sissnow ! snow in snow model
458	REAL, DIMENSION(klon), INTENT(OUT) :: runoff ! runoff on land ice
459	! Martin
460
461	! Local variables with attribute SAVE
462	!****************************************************************************************
463	INTEGER, SAVE :: nhoridbg, nidbg ! variables for IOIPSL
464	!$OMP THREADPRIVATE(nhoridbg, nidbg)
465	LOGICAL, SAVE :: debugindex=.FALSE.
466	!$OMP THREADPRIVATE(debugindex)
467	LOGICAL, SAVE :: first_call=.TRUE.
468	!$OMP THREADPRIVATE(first_call)
469	CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf
470	!$OMP THREADPRIVATE(cl_surf)
471
472	! Other local variables
473	!****************************************************************************************
474	INTEGER :: iflag_split
475	INTEGER :: i, k, nsrf
476	INTEGER :: knon, j
477	INTEGER :: idayref
478	INTEGER , DIMENSION(klon) :: ni
479	REAL :: yt1_new
480	REAL :: zx_alf1, zx_alf2 !valeur ambiante par extrapola
481	REAL :: amn, amx
482	REAL :: f1 ! fraction de longeurs visibles parmi tout SW intervalle
483	REAL, DIMENSION(klon) :: r_co2_ppm ! taux CO2 atmosphere
484	REAL, DIMENSION(klon) :: yts, yz0m, yz0h, ypct
485	!albedo SB >>>
486	REAL, DIMENSION(klon) :: yalb,yalb_vis
487	!albedo SB <<<
488	REAL, DIMENSION(klon) :: yu1, yv1
489	REAL, DIMENSION(klon) :: ysnow, yqsurf, yagesno, yqsol
490	REAL, DIMENSION(klon) :: yrain_f, ysnow_f
491	REAL, DIMENSION(klon) :: ysolsw, ysollw
492	REAL, DIMENSION(klon) :: yfder
493	REAL, DIMENSION(klon) :: yrugoro
494	REAL, DIMENSION(klon) :: yfluxlat
495	REAL, DIMENSION(klon) :: y_d_ts
496	REAL, DIMENSION(klon) :: y_flux_t1, y_flux_q1
497	REAL, DIMENSION(klon) :: y_dflux_t, y_dflux_q
498	REAL, DIMENSION(klon) :: y_flux_u1, y_flux_v1
499	REAL, DIMENSION(klon) :: yt2m, yq2m, yu10m
500	REAL, DIMENSION(klon) :: yustar
501	REAL, DIMENSION(klon) :: ywstar
502	REAL, DIMENSION(klon) :: ywindsp
503	REAL, DIMENSION(klon) :: yt10m, yq10m
504	REAL, DIMENSION(klon) :: ypblh
505	REAL, DIMENSION(klon) :: ylcl
506	REAL, DIMENSION(klon) :: ycapCL
507	REAL, DIMENSION(klon) :: yoliqCL
508	REAL, DIMENSION(klon) :: ycteiCL
509	REAL, DIMENSION(klon) :: ypblT
510	REAL, DIMENSION(klon) :: ytherm
511	REAL, DIMENSION(klon) :: ytrmb1
512	REAL, DIMENSION(klon) :: ytrmb2
513	REAL, DIMENSION(klon) :: ytrmb3
514	REAL, DIMENSION(klon) :: uzon, vmer
515	REAL, DIMENSION(klon) :: tair1, qair1, tairsol
516	REAL, DIMENSION(klon) :: psfce, patm
517	REAL, DIMENSION(klon) :: qairsol, zgeo1, speed, zri1, pref !speed, zri1, pref, added by Fuxing WANG, 04/03/2015
518	REAL, DIMENSION(klon) :: rugo1
519	REAL, DIMENSION(klon) :: yfluxsens
520	REAL, DIMENSION(klon) :: AcoefH, AcoefQ, BcoefH, BcoefQ
521	REAL, DIMENSION(klon) :: AcoefU, AcoefV, BcoefU, BcoefV
522	REAL, DIMENSION(klon) :: ypsref
523	REAL, DIMENSION(klon) :: yevap, ytsurf_new, yalb3_new
524	!albedo SB >>>
525	REAL, DIMENSION(klon,nsw) :: yalb_dir_new, yalb_dif_new
526	!albedo SB <<<
527	REAL, DIMENSION(klon) :: ztsol
528	REAL, DIMENSION(klon) :: meansqT ! mean square deviation of subsurface temperatures
529	REAL, DIMENSION(klon) :: alb_m ! mean albedo for whole SW interval
530	REAL, DIMENSION(klon,klev) :: y_d_t, y_d_q, y_d_t_diss
531	REAL, DIMENSION(klon,klev) :: y_d_u, y_d_v
532	REAL, DIMENSION(klon,klev) :: y_flux_t, y_flux_q
533	REAL, DIMENSION(klon,klev) :: y_flux_u, y_flux_v
534	REAL, DIMENSION(klon,klev) :: ycoefh, ycoefm,ycoefq
535	REAL, DIMENSION(klon) :: ycdragh, ycdragm
536	REAL, DIMENSION(klon,klev) :: yu, yv
537	REAL, DIMENSION(klon,klev) :: yt, yq
538	REAL, DIMENSION(klon,klev) :: ypplay, ydelp
539	REAL, DIMENSION(klon,klev) :: delp
540	REAL, DIMENSION(klon,klev+1) :: ypaprs
541	REAL, DIMENSION(klon,klev+1) :: ytke
542	REAL, DIMENSION(klon,nsoilmx) :: ytsoil
543	CHARACTER(len=80) :: abort_message
544	CHARACTER(len=20) :: modname = 'pbl_surface'
545	LOGICAL, PARAMETER :: zxli=.FALSE. ! utiliser un jeu de fonctions simples
546	LOGICAL, PARAMETER :: check=.FALSE.
547
548	!!! nrlmd le 02/05/2011
549	!!! jyg le 07/02/2012
550	REAL, DIMENSION(klon) :: ywake_s, ywake_cstar, ywake_dens
551	!!!
552	REAL, DIMENSION(klon,klev+1) :: ytke_x, ytke_w
553	REAL, DIMENSION(klon,klev+1) :: ywake_dltke
554	REAL, DIMENSION(klon,klev) :: yu_x, yv_x, yu_w, yv_w
555	REAL, DIMENSION(klon,klev) :: yt_x, yq_x, yt_w, yq_w
556	REAL, DIMENSION(klon,klev) :: ycoefh_x, ycoefm_x, ycoefh_w, ycoefm_w
557	REAL, DIMENSION(klon,klev) :: ycoefq_x, ycoefq_w
558	REAL, DIMENSION(klon) :: ycdragh_x, ycdragm_x, ycdragh_w, ycdragm_w
559	REAL, DIMENSION(klon) :: AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x
560	REAL, DIMENSION(klon) :: AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w
561	REAL, DIMENSION(klon) :: AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x
562	REAL, DIMENSION(klon) :: AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w
563	REAL, DIMENSION(klon) :: y_flux_t1_x, y_flux_q1_x, y_flux_t1_w, y_flux_q1_w
564	REAL, DIMENSION(klon) :: y_flux_u1_x, y_flux_v1_x, y_flux_u1_w, y_flux_v1_w
565	REAL, DIMENSION(klon,klev) :: y_flux_t_x, y_flux_q_x, y_flux_t_w, y_flux_q_w
566	REAL, DIMENSION(klon,klev) :: y_flux_u_x, y_flux_v_x, y_flux_u_w, y_flux_v_w
567	REAL, DIMENSION(klon) :: yfluxlat_x, yfluxlat_w
568	REAL, DIMENSION(klon,klev) :: y_d_t_x, y_d_q_x, y_d_t_w, y_d_q_w
569	REAL, DIMENSION(klon,klev) :: y_d_t_diss_x, y_d_t_diss_w
570	REAL, DIMENSION(klon,klev) :: d_t_diss_x, d_t_diss_w
571	REAL, DIMENSION(klon,klev) :: y_d_u_x, y_d_v_x, y_d_u_w, y_d_v_w
572	REAL, DIMENSION(klon, klev, nbsrf) :: flux_t_x, flux_q_x, flux_t_w, flux_q_w
573	REAL, DIMENSION(klon, klev, nbsrf) :: flux_u_x, flux_v_x, flux_u_w, flux_v_w
574	REAL, DIMENSION(klon, nbsrf) :: fluxlat_x, fluxlat_w
575	REAL, DIMENSION(klon, klev) :: zxfluxt_x, zxfluxq_x, zxfluxt_w, zxfluxq_w
576	REAL, DIMENSION(klon, klev) :: zxfluxu_x, zxfluxv_x, zxfluxu_w, zxfluxv_w
577	REAL :: zx_qs_surf, zcor_surf, zdelta_surf
578	REAL, DIMENSION(klon) :: ytsurf_th, yqsatsurf
579	REAL, DIMENSION(klon) :: ybeta
580	REAL, DIMENSION(klon, klev) :: d_u_x
581	REAL, DIMENSION(klon, klev) :: d_u_w
582	REAL, DIMENSION(klon, klev) :: d_v_x
583	REAL, DIMENSION(klon, klev) :: d_v_w
584
585	REAL, DIMENSION(klon,klev) :: CcoefH, CcoefQ, DcoefH, DcoefQ
586	REAL, DIMENSION(klon,klev) :: CcoefU, CcoefV, DcoefU, DcoefV
587	REAL, DIMENSION(klon,klev) :: CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x
588	REAL, DIMENSION(klon,klev) :: CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w
589	REAL, DIMENSION(klon,klev) :: CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x
590	REAL, DIMENSION(klon,klev) :: CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w
591	REAL, DIMENSION(klon,klev) :: Kcoef_hq, Kcoef_m, gama_h, gama_q
592	REAL, DIMENSION(klon,klev) :: Kcoef_hq_x, Kcoef_m_x, gama_h_x, gama_q_x
593	REAL, DIMENSION(klon,klev) :: Kcoef_hq_w, Kcoef_m_w, gama_h_w, gama_q_w
594	REAL, DIMENSION(klon) :: alf_1, alf_2, alf_1_x, alf_2_x, alf_1_w, alf_2_w
595	!!!
596	!!!jyg le 08/02/2012
597	REAL, DIMENSION(klon, nbsrf) :: windsp
598	!
599	REAL, DIMENSION(klon, nbsrf) :: t2m_x
600	REAL, DIMENSION(klon, nbsrf) :: q2m_x
601	REAL, DIMENSION(klon) :: rh2m_x
602	REAL, DIMENSION(klon) :: qsat2m_x
603	REAL, DIMENSION(klon, nbsrf) :: u10m_x
604	REAL, DIMENSION(klon, nbsrf) :: v10m_x
605	REAL, DIMENSION(klon, nbsrf) :: ustar_x
606	REAL, DIMENSION(klon, nbsrf) :: wstar_x
607	!
608	REAL, DIMENSION(klon, nbsrf) :: pblh_x
609	REAL, DIMENSION(klon, nbsrf) :: plcl_x
610	REAL, DIMENSION(klon, nbsrf) :: capCL_x
611	REAL, DIMENSION(klon, nbsrf) :: oliqCL_x
612	REAL, DIMENSION(klon, nbsrf) :: cteiCL_x
613	REAL, DIMENSION(klon, nbsrf) :: pblt_x
614	REAL, DIMENSION(klon, nbsrf) :: therm_x
615	REAL, DIMENSION(klon, nbsrf) :: trmb1_x
616	REAL, DIMENSION(klon, nbsrf) :: trmb2_x
617	REAL, DIMENSION(klon, nbsrf) :: trmb3_x
618	!
619	REAL, DIMENSION(klon, nbsrf) :: t2m_w
620	REAL, DIMENSION(klon, nbsrf) :: q2m_w
621	REAL, DIMENSION(klon) :: rh2m_w
622	REAL, DIMENSION(klon) :: qsat2m_w
623	REAL, DIMENSION(klon, nbsrf) :: u10m_w
624	REAL, DIMENSION(klon, nbsrf) :: v10m_w
625	REAL, DIMENSION(klon, nbsrf) :: ustar_w
626	REAL, DIMENSION(klon, nbsrf) :: wstar_w
627	!
628	REAL, DIMENSION(klon, nbsrf) :: pblh_w
629	REAL, DIMENSION(klon, nbsrf) :: plcl_w
630	REAL, DIMENSION(klon, nbsrf) :: capCL_w
631	REAL, DIMENSION(klon, nbsrf) :: oliqCL_w
632	REAL, DIMENSION(klon, nbsrf) :: cteiCL_w
633	REAL, DIMENSION(klon, nbsrf) :: pblt_w
634	REAL, DIMENSION(klon, nbsrf) :: therm_w
635	REAL, DIMENSION(klon, nbsrf) :: trmb1_w
636	REAL, DIMENSION(klon, nbsrf) :: trmb2_w
637	REAL, DIMENSION(klon, nbsrf) :: trmb3_w
638	!
639	REAL, DIMENSION(klon) :: yt2m_x
640	REAL, DIMENSION(klon) :: yq2m_x
641	REAL, DIMENSION(klon) :: yt10m_x
642	REAL, DIMENSION(klon) :: yq10m_x
643	REAL, DIMENSION(klon) :: yu10m_x
644	REAL, DIMENSION(klon) :: yv10m_x
645	REAL, DIMENSION(klon) :: yustar_x
646	REAL, DIMENSION(klon) :: ywstar_x
647	!
648	REAL, DIMENSION(klon) :: ypblh_x
649	REAL, DIMENSION(klon) :: ylcl_x
650	REAL, DIMENSION(klon) :: ycapCL_x
651	REAL, DIMENSION(klon) :: yoliqCL_x
652	REAL, DIMENSION(klon) :: ycteiCL_x
653	REAL, DIMENSION(klon) :: ypblt_x
654	REAL, DIMENSION(klon) :: ytherm_x
655	REAL, DIMENSION(klon) :: ytrmb1_x
656	REAL, DIMENSION(klon) :: ytrmb2_x
657	REAL, DIMENSION(klon) :: ytrmb3_x
658	!
659	REAL, DIMENSION(klon) :: yt2m_w
660	REAL, DIMENSION(klon) :: yq2m_w
661	REAL, DIMENSION(klon) :: yt10m_w
662	REAL, DIMENSION(klon) :: yq10m_w
663	REAL, DIMENSION(klon) :: yu10m_w
664	REAL, DIMENSION(klon) :: yv10m_w
665	REAL, DIMENSION(klon) :: yustar_w
666	REAL, DIMENSION(klon) :: ywstar_w
667	!
668	REAL, DIMENSION(klon) :: ypblh_w
669	REAL, DIMENSION(klon) :: ylcl_w
670	REAL, DIMENSION(klon) :: ycapCL_w
671	REAL, DIMENSION(klon) :: yoliqCL_w
672	REAL, DIMENSION(klon) :: ycteiCL_w
673	REAL, DIMENSION(klon) :: ypblt_w
674	REAL, DIMENSION(klon) :: ytherm_w
675	REAL, DIMENSION(klon) :: ytrmb1_w
676	REAL, DIMENSION(klon) :: ytrmb2_w
677	REAL, DIMENSION(klon) :: ytrmb3_w
678	!
679	REAL, DIMENSION(klon) :: uzon_x, vmer_x, speed_x, zri1_x, pref_x !speed_x, zri1_x, pref_x, added by Fuxing WANG, 04/03/2015
680	REAL, DIMENSION(klon) :: zgeo1_x, tair1_x, qair1_x, tairsol_x
681	!
682	REAL, DIMENSION(klon) :: uzon_w, vmer_w, speed_w, zri1_w, pref_w !speed_w, zri1_w, pref_w, added by Fuxing WANG, 04/03/2015
683	REAL, DIMENSION(klon) :: zgeo1_w, tair1_w, qair1_w, tairsol_w
684
685	!!! jyg le 25/03/2013
686	!! Variables intermediaires pour le raccord des deux colonnes \`a la surface
687	REAL :: dd_Ch
688	REAL :: dd_Cm
689	REAL :: dd_Kh
690	REAL :: dd_Km
691	REAL :: dd_u
692	REAL :: dd_v
693	REAL :: dd_t
694	REAL :: dd_q
695	REAL :: dd_AH
696	REAL :: dd_AQ
697	REAL :: dd_AU
698	REAL :: dd_AV
699	REAL :: dd_BH
700	REAL :: dd_BQ
701	REAL :: dd_BU
702	REAL :: dd_BV
703
704	REAL :: dd_KHp
705	REAL :: dd_KQp
706	REAL :: dd_KUp
707	REAL :: dd_KVp
708
709	!!!
710	!!! nrlmd le 13/06/2011
711	REAL, DIMENSION(klon) :: y_delta_flux_t1, y_delta_flux_q1, y_delta_flux_u1, y_delta_flux_v1
712	REAL, DIMENSION(klon) :: y_delta_tsurf,delta_coef,tau_eq
713	REAL, PARAMETER :: facteur=2./sqrt(3.14)
714	REAL, PARAMETER :: effusivity=2000.
715	REAL, DIMENSION(klon) :: ytsurf_th_x,ytsurf_th_w,yqsatsurf_x,yqsatsurf_w
716	REAL, DIMENSION(klon) :: ydtsurf_th
717	REAL :: zdelta_surf_x,zdelta_surf_w,zx_qs_surf_x,zx_qs_surf_w
718	REAL :: zcor_surf_x,zcor_surf_w
719	REAL :: mod_wind_x, mod_wind_w
720	REAL :: rho1
721	REAL, DIMENSION(klon) :: Kech_h ! Coefficient d'echange pour l'energie
722	REAL, DIMENSION(klon) :: Kech_h_x, Kech_h_w
723	REAL, DIMENSION(klon) :: Kech_m
724	REAL, DIMENSION(klon) :: Kech_m_x, Kech_m_w
725	REAL, DIMENSION(klon) :: yts_x,yts_w
726	REAL, DIMENSION(klon) :: Kech_Hp, Kech_H_xp, Kech_H_wp
727	REAL, DIMENSION(klon) :: Kech_Qp, Kech_Q_xp, Kech_Q_wp
728	REAL, DIMENSION(klon) :: Kech_Up, Kech_U_xp, Kech_U_wp
729	REAL, DIMENSION(klon) :: Kech_Vp, Kech_V_xp, Kech_V_wp
730
731	REAL :: vent
732
733
734
735
736	!!!
737
738	! For debugging with IOIPSL
739	INTEGER, DIMENSION(nbp_lon*nbp_lat) :: ndexbg
740	REAL :: zjulian
741	REAL, DIMENSION(klon) :: tabindx
742	REAL, DIMENSION(nbp_lon,nbp_lat) :: zx_lon, zx_lat
743	REAL, DIMENSION(nbp_lon,nbp_lat) :: debugtab
744
745
746	REAL, DIMENSION(klon,nbsrf) :: pblh ! height of the planetary boundary layer
747	REAL, DIMENSION(klon,nbsrf) :: plcl ! condensation level
748	REAL, DIMENSION(klon,nbsrf) :: capCL
749	REAL, DIMENSION(klon,nbsrf) :: oliqCL
750	REAL, DIMENSION(klon,nbsrf) :: cteiCL
751	REAL, DIMENSION(klon,nbsrf) :: pblT
752	REAL, DIMENSION(klon,nbsrf) :: therm
753	REAL, DIMENSION(klon,nbsrf) :: trmb1 ! deep cape
754	REAL, DIMENSION(klon,nbsrf) :: trmb2 ! inhibition
755	REAL, DIMENSION(klon,nbsrf) :: trmb3 ! point Omega
756	REAL, DIMENSION(klon,nbsrf) :: zx_rh2m, zx_qsat2m
757	REAL, DIMENSION(klon,nbsrf) :: zx_t1
758	REAL, DIMENSION(klon, nbsrf) :: alb ! mean albedo for whole SW interval
759	REAL, DIMENSION(klon) :: ylwdown ! jg : temporary (ysollwdown)
760	REAL, DIMENSION(klon) :: ygustiness ! jg : temporary (ysollwdown)
761
762	REAL :: zx_qs1, zcor1, zdelta1
763
764	! Martin
765	REAL, DIMENSION(klon, nbsrf) :: sollwd ! net longwave radiation at surface
766	REAL, DIMENSION(klon) :: ytoice
767	REAL, DIMENSION(klon) :: ysnowhgt, yqsnow, ysissnow, yrunoff
768	REAL, DIMENSION(klon) :: yzsig
769	REAL, DIMENSION(klon,klev) :: ypphi
770	REAL, DIMENSION(klon) :: ycldt
771	REAL, DIMENSION(klon) :: yrmu0
772	! Martin
773
774	!****************************************************************************************
775	! End of declarations
776	!****************************************************************************************
777
778	IF (prt_level >=10) print *,' -> pbl_surface, itap ',itap
779	!
780	!!jyg iflag_split = mod(iflag_pbl_split,2)
781	iflag_split = mod(iflag_pbl_split,10)
782
783	!****************************************************************************************
784	! 1) Initialisation and validation tests
785	! Only done first time entering this subroutine
786	!
787	!****************************************************************************************
788
789	IF (first_call) THEN
790	print*,'PBL SURFACE AVEC GUSTINESS'
791	first_call=.FALSE.
792
793	! Initialize ok_flux_surf (for 1D model)
794	if (klon_glo>1) ok_flux_surf=.FALSE.
795
796	! Initilize debug IO
797	IF (debugindex .AND. mpi_size==1) THEN
798	! initialize IOIPSL output
799	idayref = day_ini
800	CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
801	CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)
802	DO i = 1, nbp_lon
803	zx_lon(i,1) = rlon(i+1)
804	zx_lon(i,nbp_lat) = rlon(i+1)
805	ENDDO
806	CALL gr_fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)
807	CALL histbeg("sous_index",nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:), &
808	1,nbp_lon,1,nbp_lat, &
809	itau_phy,zjulian,dtime,nhoridbg,nidbg)
810	! no vertical axis
811	cl_surf(1)='ter'
812	cl_surf(2)='lic'
813	cl_surf(3)='oce'
814	cl_surf(4)='sic'
815	DO nsrf=1,nbsrf
816	CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",nbp_lon, &
817	nbp_lat,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime)
818	END DO
819
820	CALL histend(nidbg)
821	CALL histsync(nidbg)
822
823	END IF
824
825	ENDIF
826
827	!****************************************************************************************
828	! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket
829	! instead of ORCHIDEE)
830	IF (qsol0>=0.) THEN
831	PRINT*,'WARNING : On impose qsol=',qsol0
832	qsol(:)=qsol0
833	ENDIF
834	!****************************************************************************************
835
836	!****************************************************************************************
837	! 2) Initialization to zero
838	!****************************************************************************************
839	!
840	! 2a) Initialization of all argument variables with INTENT(OUT)
841	!****************************************************************************************
842	cdragh(:)=0. ; cdragm(:)=0.
843	zu1(:)=0. ; zv1(:)=0.
844	!albedo SB >>>
845	alb_dir_m=0. ; alb_dif_m=0. ; alb3_lic(:)=0.
846	!albedo SB <<<
847	zxsens(:)=0. ; zxevap(:)=0. ; zxtsol(:)=0.
848	d_t_w(:,:)=0. ; d_q_w(:,:)=0. ; d_t_x(:,:)=0. ; d_q_x(:,:)=0.
849	zxfluxlat(:)=0.
850	zt2m(:)=0. ; zq2m(:)=0. ; qsat2m(:)=0. ; rh2m(:)=0.
851	d_t(:,:)=0. ; d_t_diss(:,:)=0. ; d_q(:,:)=0. ; d_u(:,:)=0. ; d_v(:,:)=0.
852	zxsens_x(:)=0. ; zxsens_w(:)=0. ; zxfluxlat_x(:)=0. ; zxfluxlat_w(:)=0.
853	cdragh_x(:)=0. ; cdragh_w(:)=0. ; cdragm_x(:)=0. ; cdragm_w(:)=0.
854	kh(:)=0. ; kh_x(:)=0. ; kh_w(:)=0.
855	slab_wfbils(:)=0.
856	s_pblh(:)=0. ; s_pblh_x(:)=0. ; s_pblh_w(:)=0.
857	s_plcl(:)=0. ; s_plcl_x(:)=0. ; s_plcl_w(:)=0.
858	s_capCL(:)=0. ; s_oliqCL(:)=0. ; s_cteiCL(:)=0. ; s_pblT(:)=0.
859	s_therm(:)=0.
860	s_trmb1(:)=0. ; s_trmb2(:)=0. ; s_trmb3(:)=0.
861	zustar(:)=0.
862	zu10m(:)=0. ; zv10m(:)=0.
863	fder_print(:)=0.
864	zxqsurf(:)=0.
865	zxfluxu(:,:)=0. ; zxfluxv(:,:)=0.
866	solsw(:,:)=0. ; sollw(:,:)=0.
867	d_ts(:,:)=0.
868	evap(:,:)=0.
869	fluxlat(:,:)=0.
870	wfbils(:,:)=0. ; wfbilo(:,:)=0.
871	wfevap(:,:)=0. ; wfrain(:,:)=0. ; wfsnow(:,:)=0.
872	flux_t(:,:,:)=0. ; flux_q(:,:,:)=0. ; flux_u(:,:,:)=0. ; flux_v(:,:,:)=0.
873	dflux_t(:)=0. ; dflux_q(:)=0.
874	zxsnow(:)=0.
875	zxfluxt(:,:)=0. ; zxfluxq(:,:)=0.
876	qsnow(:)=0. ; snowhgt(:)=0. ; to_ice(:)=0. ; sissnow(:)=0.
877	runoff(:)=0.
878	IF (iflag_pbl<20.or.iflag_pbl>=30) THEN
879	zcoefh(:,:,:) = 0.0
880	zcoefh(:,1,:) = 999999. ! zcoefh(:,k=1) should never be used
881	zcoefm(:,:,:) = 0.0
882	zcoefm(:,1,:) = 999999. !
883	ELSE
884	zcoefm(:,:,is_ave)=0.
885	zcoefh(:,:,is_ave)=0.
886	ENDIF
887	!!
888	! The components "is_ave" of tke_x and wake_deltke are "OUT" variables
889	!jyg<
890	!! tke(:,:,is_ave)=0.
891	tke_x(:,:,is_ave)=0.
892	wake_dltke(:,:,is_ave)=0.
893	!>jyg
894	!!! jyg le 23/02/2013
895	t2m(:,:) = 999999. ! t2m and q2m are meaningfull only over sub-surfaces
896	q2m(:,:) = 999999. ! actually present in the grid cell.
897	!!!
898	rh2m(:) = 0. ; qsat2m(:) = 0.
899	!!!
900	!!! jyg le 10/02/2012
901	rh2m_x(:) = 0. ; qsat2m_x(:) = 0. ; rh2m_w(:) = 0. ; qsat2m_w(:) = 0.
902	!!!
903
904	! 2b) Initialization of all local variables that will be compressed later
905	!****************************************************************************************
906	!! cdragh = 0.0 ; cdragm = 0.0 ; dflux_t = 0.0 ; dflux_q = 0.0
907	ypct = 0.0 ; yts = 0.0 ; ysnow = 0.0
908	!! zv1 = 0.0 ; yqsurf = 0.0
909	!albedo SB >>>
910	yqsurf = 0.0 ; yalb = 0.0 ; yalb_vis = 0.0
911	!albedo SB <<<
912	yrain_f = 0.0 ; ysnow_f = 0.0 ; yfder = 0.0 ; ysolsw = 0.0
913	ysollw = 0.0 ; yz0m = 0.0 ; yz0h = 0.0 ; yu1 = 0.0
914	yv1 = 0.0 ; ypaprs = 0.0 ; ypplay = 0.0
915	ydelp = 0.0 ; yu = 0.0 ; yv = 0.0 ; yt = 0.0
916	yq = 0.0 ; y_dflux_t = 0.0 ; y_dflux_q = 0.0
917	yrugoro = 0.0 ; ywindsp = 0.0
918	!! d_ts = 0.0 ; yfluxlat=0.0 ; flux_t = 0.0 ; flux_q = 0.0
919	yfluxlat=0.0
920	!! flux_u = 0.0 ; flux_v = 0.0 ; d_t = 0.0 ; d_q = 0.0
921	!! d_t_diss= 0.0 ;d_u = 0.0 ; d_v = 0.0
922	yqsol = 0.0
923	ytherm = 0.0 ; ytke=0.
924	! Martin
925	ysnowhgt = 0.0; yqsnow = 0.0 ; yrunoff = 0.0 ; ytoice =0.0
926	yalb3_new = 0.0 ; ysissnow = 0.0
927	ypphi = 0.0 ; ycldt = 0.0 ; yrmu0 = 0.0
928	! Martin
929
930	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
931	ytke_x=0. ; ytke_w=0. ; ywake_dltke=0.
932	y_d_t_x=0. ; y_d_t_w=0. ; y_d_q_x=0. ; y_d_q_w=0.
933	!! d_t_w=0. ; d_q_w=0.
934	!! d_t_x=0. ; d_q_x=0.
935	!! d_wake_dlt=0. ; d_wake_dlq=0.
936	yfluxlat_x=0. ; yfluxlat_w=0.
937	ywake_s=0. ; ywake_cstar=0. ;ywake_dens=0.
938	!!!
939	!!! nrlmd le 13/06/2011
940	tau_eq=0. ; delta_coef=0.
941	y_delta_flux_t1=0.
942	ydtsurf_th=0.
943	yts_x=0. ; yts_w=0.
944	y_delta_tsurf=0.
945	!!!
946	ytsoil = 999999.
947
948
949	! 2c) Initialization of all local variables computed within the subsurface loop and used later on
950	!****************************************************************************************
951	d_t_diss_x(:,:) = 0. ; d_t_diss_w(:,:) = 0.
952	d_u_x(:,:)=0. ; d_u_w(:,:)=0.
953	d_v_x(:,:)=0. ; d_v_w(:,:)=0.
954	flux_t_x(:,:,:)=0. ; flux_t_w(:,:,:)=0.
955	flux_q_x(:,:,:)=0. ; flux_q_w(:,:,:)=0.
956	!
957	!jyg<
958	flux_u_x(:,:,:)=0. ; flux_u_w(:,:,:)=0.
959	flux_v_x(:,:,:)=0. ; flux_v_w(:,:,:)=0.
960	fluxlat_x(:,:)=0. ; fluxlat_w(:,:)=0.
961	!>jyg
962	!
963	!jyg<
964	! pblh,plcl,capCL,cteiCL ... are meaningfull only over sub-surfaces
965	! actually present in the grid cell ==> value set to 999999.
966	!
967	!jyg<
968	ustar(:,:) = 999999.
969	wstar(:,:) = 999999.
970	windsp(:,:) = SQRT(u10m(:,:)2 + v10m(:,:)2 )
971	u10m(:,:) = 999999.
972	v10m(:,:) = 999999.
973	!>jyg
974	!
975	pblh(:,:) = 999999. ! Hauteur de couche limite
976	plcl(:,:) = 999999. ! Niveau de condensation de la CLA
977	capCL(:,:) = 999999. ! CAPE de couche limite
978	oliqCL(:,:) = 999999. ! eau_liqu integree de couche limite
979	cteiCL(:,:) = 999999. ! cloud top instab. crit. couche limite
980	pblt(:,:) = 999999. ! T a la Hauteur de couche limite
981	therm(:,:) = 999999.
982	trmb1(:,:) = 999999. ! deep_cape
983	trmb2(:,:) = 999999. ! inhibition
984	trmb3(:,:) = 999999. ! Point Omega
985	!
986	t2m_x(:,:) = 999999.
987	q2m_x(:,:) = 999999.
988	ustar_x(:,:) = 999999.
989	wstar_x(:,:) = 999999.
990	u10m_x(:,:) = 999999.
991	v10m_x(:,:) = 999999.
992	!
993	pblh_x(:,:) = 999999. ! Hauteur de couche limite
994	plcl_x(:,:) = 999999. ! Niveau de condensation de la CLA
995	capCL_x(:,:) = 999999. ! CAPE de couche limite
996	oliqCL_x(:,:) = 999999. ! eau_liqu integree de couche limite
997	cteiCL_x(:,:) = 999999. ! cloud top instab. crit. couche limite
998	pblt_x(:,:) = 999999. ! T a la Hauteur de couche limite
999	therm_x(:,:) = 999999.
1000	trmb1_x(:,:) = 999999. ! deep_cape
1001	trmb2_x(:,:) = 999999. ! inhibition
1002	trmb3_x(:,:) = 999999. ! Point Omega
1003	!
1004	t2m_w(:,:) = 999999.
1005	q2m_w(:,:) = 999999.
1006	ustar_w(:,:) = 999999.
1007	wstar_w(:,:) = 999999.
1008	u10m_w(:,:) = 999999.
1009	v10m_w(:,:) = 999999.
1010
1011	pblh_w(:,:) = 999999. ! Hauteur de couche limite
1012	plcl_w(:,:) = 999999. ! Niveau de condensation de la CLA
1013	capCL_w(:,:) = 999999. ! CAPE de couche limite
1014	oliqCL_w(:,:) = 999999. ! eau_liqu integree de couche limite
1015	cteiCL_w(:,:) = 999999. ! cloud top instab. crit. couche limite
1016	pblt_w(:,:) = 999999. ! T a la Hauteur de couche limite
1017	therm_w(:,:) = 999999.
1018	trmb1_w(:,:) = 999999. ! deep_cape
1019	trmb2_w(:,:) = 999999. ! inhibition
1020	trmb3_w(:,:) = 999999. ! Point Omega
1021	!!!
1022	!
1023	!!!
1024	!****************************************************************************************
1025	! 3) - Calculate pressure thickness of each layer
1026	! - Calculate the wind at first layer
1027	! - Mean calculations of albedo
1028	! - Calculate net radiance at sub-surface
1029	!****************************************************************************************
1030	DO k = 1, klev
1031	DO i = 1, klon
1032	delp(i,k) = paprs(i,k)-paprs(i,k+1)
1033	ENDDO
1034	ENDDO
1035
1036	!****************************************************************************************
1037	! Test for rugos........ from physiq.. A la fin plutot???
1038	!
1039	!****************************************************************************************
1040
1041	DO nsrf = 1, nbsrf
1042	DO i = 1, klon
1043	z0m(i,nsrf) = MAX(z0m(i,nsrf),z0min)
1044	z0h(i,nsrf) = MAX(z0h(i,nsrf),z0min)
1045	ENDDO
1046	ENDDO
1047
1048	! Mean calculations of albedo
1049	!
1050	! * alb : mean albedo for whole SW interval
1051	!
1052	! Mean albedo for grid point
1053	! * alb_m : mean albedo at whole SW interval
1054
1055	alb_dir_m(:,:) = 0.0
1056	alb_dif_m(:,:) = 0.0
1057	DO k = 1, nsw
1058	DO nsrf = 1, nbsrf
1059	DO i = 1, klon
1060	alb_dir_m(i,k) = alb_dir_m(i,k) + alb_dir(i,k,nsrf) * pctsrf(i,nsrf)
1061	alb_dif_m(i,k) = alb_dif_m(i,k) + alb_dif(i,k,nsrf) * pctsrf(i,nsrf)
1062	ENDDO
1063	ENDDO
1064	ENDDO
1065
1066	! We here suppose the fraction f1 of incoming radiance of visible radiance
1067	! as a fraction of all shortwave radiance
1068	f1 = 0.5
1069	! f1 = 1 ! put f1=1 to recreate old calculations
1070
1071	!f1 is already included with SFRWL values in each surf files
1072	alb=0.0
1073	DO k=1,nsw
1074	DO nsrf = 1, nbsrf
1075	DO i = 1, klon
1076	alb(i,nsrf) = alb(i,nsrf) + alb_dir(i,k,nsrf)*SFRWL(k)
1077	ENDDO
1078	ENDDO
1079	ENDDO
1080
1081	alb_m=0.0
1082	DO k = 1,nsw
1083	DO i = 1, klon
1084	alb_m(i) = alb_m(i) + alb_dir_m(i,k)*SFRWL(k)
1085	END DO
1086	ENDDO
1087	!albedo SB <<<
1088
1089
1090
1091	! Calculation of mean temperature at surface grid points
1092	ztsol(:) = 0.0
1093	DO nsrf = 1, nbsrf
1094	DO i = 1, klon
1095	ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf)
1096	ENDDO
1097	ENDDO
1098
1099	! Linear distrubution on sub-surface of long- and shortwave net radiance
1100	DO nsrf = 1, nbsrf
1101	DO i = 1, klon
1102	sollw(i,nsrf) = sollw_m(i) + 4.0RSIGMAztsol(i)*3 (ztsol(i)-ts(i,nsrf))
1103
1104	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1105	! ! Martin
1106	! Apparently introduced for sisvat but not used
1107	! sollwd(i,nsrf)= sollwd_m(i)
1108	! ! Martin
1109	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1110
1111	solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i))
1112	ENDDO
1113	ENDDO
1114	!
1115	!<al1: second order corrections
1116	!- net = dwn -up; up=sig( T4 + 4sum%T3T' + 6sum%T2T'2 +...)
1117	IF (iflag_order2_sollw == 1) THEN
1118	meansqT(:) = 0. ! as working buffer
1119	DO nsrf = 1, nbsrf
1120	DO i = 1, klon
1121	meansqT(i) = meansqT(i)+(ts(i,nsrf)-ztsol(i))*2 pctsrf(i,nsrf)
1122	END DO
1123	END DO
1124	DO nsrf = 1, nbsrf
1125	DO i = 1, klon
1126	sollw(i,nsrf) = sollw(i,nsrf) &
1127	+ 6.0RSIGMAztsol(i)*2 (meansqT(i)-(ztsol(i)-ts(i,nsrf))**2)
1128	ENDDO
1129	ENDDO
1130	ENDIF ! iflag_order2_sollw == 1
1131	!>al1
1132
1133	!****************************************************************************************
1134	! 4) Loop over different surfaces
1135	!
1136	! Only points containing a fraction of the sub surface will be treated.
1137	!
1138	!****************************************************************************************
1139
1140	loop_nbsrf: DO nsrf = 1, nbsrf
1141	IF (prt_level >=10) print *,' Loop nsrf ',nsrf
1142
1143	! Search for index(ni) and size(knon) of domaine to treat
1144	ni(:) = 0
1145	knon = 0
1146	DO i = 1, klon
1147	IF (pctsrf(i,nsrf) > 0.) THEN
1148	knon = knon + 1
1149	ni(knon) = i
1150	ENDIF
1151	ENDDO
1152
1153	!!! jyg le 19/08/2012
1154	! IF (knon <= 0) THEN
1155	! IF (prt_level >= 10) print *,' no grid point for nsrf= ',nsrf
1156	! cycle loop_nbsrf
1157	! ENDIF
1158	!!!
1159
1160	! write index, with IOIPSL
1161	IF (debugindex .AND. mpi_size==1) THEN
1162	tabindx(:)=0.
1163	DO i=1,knon
1164	tabindx(i)=REAL(i)
1165	END DO
1166	debugtab(:,:) = 0.
1167	ndexbg(:) = 0
1168	CALL gath2cpl(tabindx,debugtab,knon,ni)
1169	CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,nbp_lon*nbp_lat, ndexbg)
1170	ENDIF
1171
1172	!****************************************************************************************
1173	! 5) Compress variables
1174	!
1175	!****************************************************************************************
1176
1177	DO j = 1, knon
1178	i = ni(j)
1179	ypct(j) = pctsrf(i,nsrf)
1180	yts(j) = ts(i,nsrf)
1181	ysnow(j) = snow(i,nsrf)
1182	yqsurf(j) = qsurf(i,nsrf)
1183	yalb(j) = alb(i,nsrf)
1184	!albedo SB >>>
1185	yalb_vis(j) = alb_dir(i,1,nsrf)
1186	if(nsw==6)then
1187	yalb_vis(j)=(alb_dir(i,1,nsrf)SFRWL(1)+alb_dir(i,2,nsrf)SFRWL(2) &
1188	+alb_dir(i,3,nsrf)*SFRWL(3))/(SFRWL(1)+SFRWL(2)+SFRWL(3))
1189	endif
1190	!albedo SB <<<
1191	yrain_f(j) = rain_f(i)
1192	ysnow_f(j) = snow_f(i)
1193	yagesno(j) = agesno(i,nsrf)
1194	yfder(j) = fder(i)
1195	ylwdown(j) = lwdown_m(i)
1196	ygustiness(j) = gustiness(i)
1197	ysolsw(j) = solsw(i,nsrf)
1198	ysollw(j) = sollw(i,nsrf)
1199	yz0m(j) = z0m(i,nsrf)
1200	yz0h(j) = z0h(i,nsrf)
1201	yrugoro(j) = rugoro(i)
1202	yu1(j) = u(i,1)
1203	yv1(j) = v(i,1)
1204	ypaprs(j,klev+1) = paprs(i,klev+1)
1205	!jyg<
1206	!! ywindsp(j) = SQRT(u10m(i,nsrf)2 + v10m(i,nsrf)2 )
1207	ywindsp(j) = windsp(i,nsrf)
1208	!>jyg
1209	! Martin
1210	yzsig(j) = zsig(i)
1211	ycldt(j) = cldt(i)
1212	yrmu0(j) = rmu0(i)
1213	! Martin
1214	!!! nrlmd le 13/06/2011
1215	y_delta_tsurf(j)=delta_tsurf(i,nsrf)
1216	!!!
1217	END DO
1218
1219	DO k = 1, klev
1220	DO j = 1, knon
1221	i = ni(j)
1222	ypaprs(j,k) = paprs(i,k)
1223	ypplay(j,k) = pplay(i,k)
1224	ydelp(j,k) = delp(i,k)
1225	ENDDO
1226	ENDDO
1227	!!! jyg le 07/02/2012 et le 10/04/2013
1228	DO k = 1, klev
1229	DO j = 1, knon
1230	i = ni(j)
1231	!jyg<
1232	!! ytke(j,k) = tke(i,k,nsrf)
1233	ytke(j,k) = tke_x(i,k,nsrf)
1234	!>jyg
1235	yu(j,k) = u(i,k)
1236	yv(j,k) = v(i,k)
1237	yt(j,k) = t(i,k)
1238	yq(j,k) = q(i,k)
1239	ENDDO
1240	ENDDO
1241	!
1242	IF (iflag_split .ge.1) THEN
1243	!!! nrlmd le 02/05/2011
1244	DO k = 1, klev
1245	DO j = 1, knon
1246	i = ni(j)
1247	yu_x(j,k) = u(i,k)
1248	yv_x(j,k) = v(i,k)
1249	yt_x(j,k) = t(i,k)-wake_s(i)*wake_dlt(i,k)
1250	yq_x(j,k) = q(i,k)-wake_s(i)*wake_dlq(i,k)
1251	yu_w(j,k) = u(i,k)
1252	yv_w(j,k) = v(i,k)
1253	yt_w(j,k) = t(i,k)+(1.-wake_s(i))*wake_dlt(i,k)
1254	yq_w(j,k) = q(i,k)+(1.-wake_s(i))*wake_dlq(i,k)
1255	!!!
1256	ENDDO
1257	ENDDO
1258	!!! nrlmd le 02/05/2011
1259	DO k = 1, klev+1
1260	DO j = 1, knon
1261	i = ni(j)
1262	!jyg<
1263	!! ytke_x(j,k) = tke(i,k,nsrf)-wake_s(i)*wake_dltke(i,k,nsrf)
1264	!! ytke_w(j,k) = tke(i,k,nsrf)+(1.-wake_s(i))*wake_dltke(i,k,nsrf)
1265	!! ywake_dltke(j,k) = wake_dltke(i,k,nsrf)
1266	!! ytke(j,k) = tke(i,k,nsrf)
1267	!
1268	ytke_x(j,k) = tke_x(i,k,nsrf)
1269	ytke(j,k) = tke_x(i,k,nsrf)+wake_s(i)*wake_dltke(i,k,nsrf)
1270	ytke_w(j,k) = tke_x(i,k,nsrf)+wake_dltke(i,k,nsrf)
1271	ywake_dltke(j,k) = wake_dltke(i,k,nsrf)
1272	!>jyg
1273	ENDDO
1274	ENDDO
1275	!!!
1276	!!! jyg le 07/02/2012
1277	DO j = 1, knon
1278	i = ni(j)
1279	ywake_s(j)=wake_s(i)
1280	ywake_cstar(j)=wake_cstar(i)
1281	ywake_dens(j)=wake_dens(i)
1282	ENDDO
1283	!!!
1284	!!! nrlmd le 13/06/2011
1285	DO j=1,knon
1286	yts_x(j)=yts(j)-ywake_s(j)*y_delta_tsurf(j)
1287	yts_w(j)=yts(j)+(1.-ywake_s(j))*y_delta_tsurf(j)
1288	ENDDO
1289	!!!
1290	ENDIF ! (iflag_split .ge.1)
1291	!!!
1292	DO k = 1, nsoilmx
1293	DO j = 1, knon
1294	i = ni(j)
1295	ytsoil(j,k) = ftsoil(i,k,nsrf)
1296	END DO
1297	END DO
1298
1299	! qsol(water height in soil) only for bucket continental model
1300	IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN
1301	DO j = 1, knon
1302	i = ni(j)
1303	yqsol(j) = qsol(i)
1304	END DO
1305	ENDIF
1306
1307	!****************************************************************************************
1308	! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm.
1309	!
1310	!****************************************************************************************
1311
1312	!!! jyg le 07/02/2012
1313	IF (iflag_split .eq.0) THEN
1314	!!!
1315	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
1316	! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
1317	! CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
1318	! yu(:,1), yv(:,1), yt(:,1), yq(:,1), &
1319	! yts, yqsurf, yrugos, &
1320	! ycdragm, ycdragh )
1321	! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
1322	DO i = 1, knon
1323	! print*,'PBL ',i,RD
1324	! print*,'PBL ',yt(i,1),ypaprs(i,1),ypplay(i,1)
1325	zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
1326	* (ypaprs(i,1)-ypplay(i,1))
1327	speed(i) = SQRT(yu(i,1)2+yv(i,1)2)
1328	END DO
1329	CALL cdrag(knon, nsrf, &
1330	speed, yt(:,1), yq(:,1), zgeo1, ypaprs(:,1),&
1331	yts, yqsurf, yz0m, yz0h, &
1332	ycdragm, ycdragh, zri1, pref )
1333
1334	! --- special Dice: on force cdragm ( a defaut de forcer ustar) MPL 05082013
1335	IF (ok_prescr_ust) then
1336	DO i = 1, knon
1337	print *,'ycdragm avant=',ycdragm(i)
1338	vent= sqrt(yu(i,1)yu(i,1)+yv(i,1)yv(i,1))
1339	! ycdragm(i) = ustust/(1.+(yu(i,1)yu(i,1)+yv(i,1)*yv(i,1)))
1340	! ycdragm(i) = ustust/((1.+sqrt(yu(i,1)yu(i,1)+yv(i,1)*yv(i,1))) &
1341	! sqrt(yu(i,1)yu(i,1)+yv(i,1)*yv(i,1)))
1342	ycdragm(i) = ust*ust/(1.+vent)/vent
1343	! print *,'ycdragm ust yu yv apres=',ycdragm(i),ust,yu(i,1),yv(i,1)
1344	ENDDO
1345	ENDIF
1346	IF (prt_level >=10) print *,'clcdrag -> ycdragh ', ycdragh
1347	ELSE !(iflag_split .eq.0)
1348
1349	! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
1350	! CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
1351	! yu_x(:,1), yv_x(:,1), yt_x(:,1), yq_x(:,1), &
1352	! yts_x, yqsurf, yrugos, &
1353	! ycdragm_x, ycdragh_x )
1354	! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
1355	DO i = 1, knon
1356	zgeo1_x(i) = RD * yt_x(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
1357	* (ypaprs(i,1)-ypplay(i,1))
1358	speed_x(i) = SQRT(yu_x(i,1)2+yv_x(i,1)2)
1359	END DO
1360	CALL cdrag(knon, nsrf, &
1361	speed_x, yt_x(:,1), yq_x(:,1), zgeo1_x, ypaprs(:,1),&
1362	yts_x, yqsurf, yz0m, yz0h, &
1363	ycdragm_x, ycdragh_x, zri1_x, pref_x )
1364
1365	! --- special Dice. JYG+MPL 25112013
1366	IF (ok_prescr_ust) then
1367	DO i = 1, knon
1368	! print *,'ycdragm_x avant=',ycdragm_x(i)
1369	vent= sqrt(yu_x(i,1)yu_x(i,1)+yv_x(i,1)yv_x(i,1))
1370	ycdragm_x(i) = ust*ust/(1.+vent)/vent
1371	! print *,'ycdragm_x ust yu yv apres=',ycdragm_x(i),ust,yu_x(i,1),yv_x(i,1)
1372	ENDDO
1373	ENDIF
1374	IF (prt_level >=10) print *,'clcdrag -> ycdragh_x ', ycdragh_x
1375	!
1376	! Faire disparaitre les lignes commentees fin 2015 (le temps des tests)
1377	! CALL clcdrag( knon, nsrf, ypaprs, ypplay, &
1378	! yu_w(:,1), yv_w(:,1), yt_w(:,1), yq_w(:,1), &
1379	! yts_w, yqsurf, yz0m, &
1380	! ycdragm_w, ycdragh_w )
1381	! Fuxing WANG, 04/03/2015, replace the clcdrag by the merged version: cdrag
1382	DO i = 1, knon
1383	zgeo1_w(i) = RD * yt_w(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
1384	* (ypaprs(i,1)-ypplay(i,1))
1385	speed_w(i) = SQRT(yu_w(i,1)2+yv_w(i,1)2)
1386	END DO
1387	CALL cdrag(knon, nsrf, &
1388	speed_w, yt_w(:,1), yq_w(:,1), zgeo1_w, ypaprs(:,1),&
1389	yts_w, yqsurf, yz0m, yz0h, &
1390	ycdragm_w, ycdragh_w, zri1_w, pref_w )
1391
1392	! --- special Dice. JYG+MPL 25112013 puis BOMEX
1393	IF (ok_prescr_ust) then
1394	DO i = 1, knon
1395	! print *,'ycdragm_w avant=',ycdragm_w(i)
1396	vent= sqrt(yu_w(i,1)yu_w(i,1)+yv_w(i,1)yv_w(i,1))
1397	ycdragm_w(i) = ust*ust/(1.+vent)/vent
1398	! print *,'ycdragm_w ust yu yv apres=',ycdragm_w(i),ust,yu_w(i,1),yv_w(i,1)
1399	ENDDO
1400	ENDIF
1401	IF (prt_level >=10) print *,'clcdrag -> ycdragh_w ', ycdragh_w
1402	!!!
1403	ENDIF ! (iflag_split .eq.0)
1404	!!!
1405
1406
1407	!****************************************************************************************
1408	! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefh et ycoefm.
1409	!
1410	!****************************************************************************************
1411
1412	!!! jyg le 07/02/2012
1413	IF (iflag_split .eq.0) THEN
1414	!!!
1415	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
1416	IF (prt_level >=10) THEN
1417	print *,' args coef_diff_turb: yu ', yu
1418	print *,' args coef_diff_turb: yv ', yv
1419	print *,' args coef_diff_turb: yq ', yq
1420	print *,' args coef_diff_turb: yt ', yt
1421	print *,' args coef_diff_turb: yts ', yts
1422	print *,' args coef_diff_turb: yz0m ', yz0m
1423	print *,' args coef_diff_turb: yqsurf ', yqsurf
1424	print *,' args coef_diff_turb: ycdragm ', ycdragm
1425	print *,' args coef_diff_turb: ycdragh ', ycdragh
1426	print *,' args coef_diff_turb: ytke ', ytke
1427	ENDIF
1428	CALL coef_diff_turb(dtime, nsrf, knon, ni, &
1429	ypaprs, ypplay, yu, yv, yq, yt, yts, yqsurf, ycdragm, &
1430	ycoefm, ycoefh, ytke)
1431	IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
1432	! In this case, coef_diff_turb is called for the Cd only
1433	DO k = 2, klev
1434	DO j = 1, knon
1435	i = ni(j)
1436	ycoefh(j,k) = zcoefh(i,k,nsrf)
1437	ycoefm(j,k) = zcoefm(i,k,nsrf)
1438	ENDDO
1439	ENDDO
1440	ENDIF
1441	IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh ',ycoefh
1442	!
1443	ELSE !(iflag_split .eq.0)
1444	IF (prt_level >=10) THEN
1445	print *,' args coef_diff_turb: yu_x ', yu_x
1446	print *,' args coef_diff_turb: yv_x ', yv_x
1447	print *,' args coef_diff_turb: yq_x ', yq_x
1448	print *,' args coef_diff_turb: yt_x ', yt_x
1449	print *,' args coef_diff_turb: yts_x ', yts_x
1450	print *,' args coef_diff_turb: yqsurf ', yqsurf
1451	print *,' args coef_diff_turb: ycdragm_x ', ycdragm_x
1452	print *,' args coef_diff_turb: ycdragh_x ', ycdragh_x
1453	print *,' args coef_diff_turb: ytke_x ', ytke_x
1454	ENDIF
1455	CALL coef_diff_turb(dtime, nsrf, knon, ni, &
1456	ypaprs, ypplay, yu_x, yv_x, yq_x, yt_x, yts_x, yqsurf, ycdragm_x, &
1457	ycoefm_x, ycoefh_x, ytke_x)
1458	IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
1459	! In this case, coef_diff_turb is called for the Cd only
1460	DO k = 2, klev
1461	DO j = 1, knon
1462	i = ni(j)
1463	ycoefh_x(j,k) = zcoefh(i,k,nsrf)
1464	ycoefm_x(j,k) = zcoefm(i,k,nsrf)
1465	ENDDO
1466	ENDDO
1467	ENDIF
1468	IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh_x ',ycoefh_x
1469	!
1470	IF (prt_level >=10) THEN
1471	print *,' args coef_diff_turb: yu_w ', yu_w
1472	print *,' args coef_diff_turb: yv_w ', yv_w
1473	print *,' args coef_diff_turb: yq_w ', yq_w
1474	print *,' args coef_diff_turb: yt_w ', yt_w
1475	print *,' args coef_diff_turb: yts_w ', yts_w
1476	print *,' args coef_diff_turb: yqsurf ', yqsurf
1477	print *,' args coef_diff_turb: ycdragm_w ', ycdragm_w
1478	print *,' args coef_diff_turb: ycdragh_w ', ycdragh_w
1479	print *,' args coef_diff_turb: ytke_w ', ytke_w
1480	ENDIF
1481	CALL coef_diff_turb(dtime, nsrf, knon, ni, &
1482	ypaprs, ypplay, yu_w, yv_w, yq_w, yt_w, yts_w, yqsurf, ycdragm_w, &
1483	ycoefm_w, ycoefh_w, ytke_w)
1484	IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
1485	! In this case, coef_diff_turb is called for the Cd only
1486	DO k = 2, klev
1487	DO j = 1, knon
1488	i = ni(j)
1489	ycoefh_w(j,k) = zcoefh(i,k,nsrf)
1490	ycoefm_w(j,k) = zcoefm(i,k,nsrf)
1491	ENDDO
1492	ENDDO
1493	ENDIF
1494	IF (prt_level >=10) print *,'coef_diff_turb -> ycoefh_w ',ycoefh_w
1495	!
1496	!!!jyg le 10/04/2013
1497	!! En attendant de traiter le transport des traceurs dans les poches froides, formule
1498	!! arbitraire pour ycoefh et ycoefm
1499	DO k = 2,klev
1500	DO j = 1,knon
1501	ycoefh(j,k) = ycoefh_x(j,k) + ywake_s(j)*(ycoefh_w(j,k) - ycoefh_x(j,k))
1502	ycoefm(j,k) = ycoefm_x(j,k) + ywake_s(j)*(ycoefm_w(j,k) - ycoefm_x(j,k))
1503	ENDDO
1504	ENDDO
1505	!!!
1506	ENDIF ! (iflag_split .eq.0)
1507	!!!
1508
1509	!****************************************************************************************
1510	!
1511	! 8) "La descente" - "The downhill"
1512	!
1513	! climb_hq_down and climb_wind_down calculate the coefficients
1514	! Ccoef_X et Dcoef_X for X=[H, Q, U, V].
1515	! Only the coefficients at surface for H and Q are returned.
1516	!
1517	!****************************************************************************************
1518
1519	! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q
1520	!!! jyg le 07/02/2012
1521	IF (iflag_split .eq.0) THEN
1522	!!!
1523	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
1524	CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, &
1525	ydelp, yt, yq, dtime, &
1526	!!! jyg le 09/05/2011
1527	CcoefH, CcoefQ, DcoefH, DcoefQ, &
1528	Kcoef_hq, gama_q, gama_h, &
1529	!!!
1530	AcoefH, AcoefQ, BcoefH, BcoefQ)
1531	ELSE !(iflag_split .eq.0)
1532	CALL climb_hq_down(knon, ycoefh_x, ypaprs, ypplay, &
1533	ydelp, yt_x, yq_x, dtime, &
1534	!!! nrlmd le 02/05/2011
1535	CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x, &
1536	Kcoef_hq_x, gama_q_x, gama_h_x, &
1537	!!!
1538	AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x)
1539	!
1540	CALL climb_hq_down(knon, ycoefh_w, ypaprs, ypplay, &
1541	ydelp, yt_w, yq_w, dtime, &
1542	!!! nrlmd le 02/05/2011
1543	CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w, &
1544	Kcoef_hq_w, gama_q_w, gama_h_w, &
1545	!!!
1546	AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w)
1547	!!!
1548	ENDIF ! (iflag_split .eq.0)
1549	!!!
1550
1551	! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V
1552	!!! jyg le 07/02/2012
1553	IF (iflag_split .eq.0) THEN
1554	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
1555	CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv, &
1556	!!! jyg le 09/05/2011
1557	CcoefU, CcoefV, DcoefU, DcoefV, &
1558	Kcoef_m, alf_1, alf_2, &
1559	!!!
1560	AcoefU, AcoefV, BcoefU, BcoefV)
1561	ELSE ! (iflag_split .eq.0)
1562	CALL climb_wind_down(knon, dtime, ycoefm_x, ypplay, ypaprs, yt_x, ydelp, yu_x, yv_x, &
1563	!!! nrlmd le 02/05/2011
1564	CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x, &
1565	Kcoef_m_x, alf_1_x, alf_2_x, &
1566	!!!
1567	AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x)
1568	!
1569	CALL climb_wind_down(knon, dtime, ycoefm_w, ypplay, ypaprs, yt_w, ydelp, yu_w, yv_w, &
1570	!!! nrlmd le 02/05/2011
1571	CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w, &
1572	Kcoef_m_w, alf_1_w, alf_2_w, &
1573	!!!
1574	AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w)
1575	!!!
1576	ENDIF ! (iflag_split .eq.0)
1577	!!!
1578
1579	!****************************************************************************************
1580	! 9) Small calculations
1581	!
1582	!****************************************************************************************
1583
1584	! - Reference pressure is given the values at surface level
1585	ypsref(:) = ypaprs(:,1)
1586
1587	! - CO2 field on 2D grid to be sent to ORCHIDEE
1588	! Transform to compressed field
1589	IF (carbon_cycle_cpl) THEN
1590	DO i=1,knon
1591	r_co2_ppm(i) = co2_send(ni(i))
1592	END DO
1593	ELSE
1594	r_co2_ppm(:) = co2_ppm ! Constant field
1595	END IF
1596
1597	!!! nrlmd le 13/06/2011
1598	!----- On finit le calcul des coefficients d'\'echange:on multiplie le cdrag par le module du vent et la densit\'e dans la premi\`ere couche
1599	! Kech_h_x(j) = ycdragh_x(j) * &
1600	! (1.0+SQRT(yu_x(j,1)2+yv_x(j,1)2)) * &
1601	! ypplay(j,1)/(RD*yt_x(j,1))
1602	! Kech_h_w(j) = ycdragh_w(j) * &
1603	! (1.0+SQRT(yu_w(j,1)2+yv_w(j,1)2)) * &
1604	! ypplay(j,1)/(RD*yt_w(j,1))
1605	! Kech_h(j) = (1.-ywake_s(j))Kech_h_x(j)+ywake_s(j)Kech_h_w(j)
1606	!
1607	! Kech_m_x(j) = ycdragm_x(j) * &
1608	! (1.0+SQRT(yu_x(j,1)2+yv_x(j,1)2)) * &
1609	! ypplay(j,1)/(RD*yt_x(j,1))
1610	! Kech_m_w(j) = ycdragm_w(j) * &
1611	! (1.0+SQRT(yu_w(j,1)2+yv_w(j,1)2)) * &
1612	! ypplay(j,1)/(RD*yt_w(j,1))
1613	! Kech_m(j) = (1.-ywake_s(j))Kech_m_x(j)+ywake_s(j)Kech_m_w(j)
1614	!!!
1615
1616	!!! nrlmd le 02/05/2011 -----------------------On raccorde les 2 colonnes dans la couche 1
1617	!----------------------------------------------------------------------------------------
1618	!!! jyg le 07/02/2012
1619	IF (iflag_split .eq.1) THEN
1620	!!!
1621	!!! jyg le 09/04/2013 ; passage aux nouvelles expressions en differences
1622
1623	DO j=1,knon
1624	!
1625	! Calcul des coefficients d echange
1626	mod_wind_x = 1.0+SQRT(yu_x(j,1)2+yv_x(j,1)2)
1627	mod_wind_w = 1.0+SQRT(yu_w(j,1)2+yv_w(j,1)2)
1628	rho1 = ypplay(j,1)/(RD*yt(j,1))
1629	Kech_h_x(j) = ycdragh_x(j) * mod_wind_x * rho1
1630	Kech_h_w(j) = ycdragh_w(j) * mod_wind_w * rho1
1631	Kech_m_x(j) = ycdragm_x(j) * mod_wind_x * rho1
1632	Kech_m_w(j) = ycdragm_w(j) * mod_wind_w * rho1
1633	!
1634	dd_Kh = Kech_h_w(j) - Kech_h_x(j)
1635	dd_Km = Kech_m_w(j) - Kech_m_x(j)
1636	IF (prt_level >=10) THEN
1637	print *,' mod_wind_x, mod_wind_w ', mod_wind_x, mod_wind_w
1638	print *,' rho1 ',rho1
1639	print *,' ycdragh_x(j),ycdragm_x(j) ',ycdragh_x(j),ycdragm_x(j)
1640	print *,' ycdragh_w(j),ycdragm_w(j) ',ycdragh_w(j),ycdragm_w(j)
1641	print *,' dd_Kh: ',dd_KH
1642	ENDIF
1643	!
1644	Kech_h(j) = Kech_h_x(j) + ywake_s(j)*dd_Kh
1645	Kech_m(j) = Kech_m_x(j) + ywake_s(j)*dd_Km
1646	!
1647	! Calcul des coefficients d echange corriges des retroactions
1648	Kech_H_xp(j) = Kech_h_x(j)/(1.-BcoefH_x(j)Kech_h_x(j)dtime)
1649	Kech_H_wp(j) = Kech_h_w(j)/(1.-BcoefH_w(j)Kech_h_w(j)dtime)
1650	Kech_Q_xp(j) = Kech_h_x(j)/(1.-BcoefQ_x(j)Kech_h_x(j)dtime)
1651	Kech_Q_wp(j) = Kech_h_w(j)/(1.-BcoefQ_w(j)Kech_h_w(j)dtime)
1652	Kech_U_xp(j) = Kech_m_x(j)/(1.-BcoefU_x(j)Kech_m_x(j)dtime)
1653	Kech_U_wp(j) = Kech_m_w(j)/(1.-BcoefU_w(j)Kech_m_w(j)dtime)
1654	Kech_V_xp(j) = Kech_m_x(j)/(1.-BcoefV_x(j)Kech_m_x(j)dtime)
1655	Kech_V_wp(j) = Kech_m_w(j)/(1.-BcoefV_w(j)Kech_m_w(j)dtime)
1656	!
1657	dd_KHp = Kech_H_wp(j) - Kech_H_xp(j)
1658	dd_KQp = Kech_Q_wp(j) - Kech_Q_xp(j)
1659	dd_KUp = Kech_U_wp(j) - Kech_U_xp(j)
1660	dd_KVp = Kech_V_wp(j) - Kech_V_xp(j)
1661	!
1662	Kech_Hp(j) = Kech_H_xp(j) + ywake_s(j)*dd_KHp
1663	Kech_Qp(j) = Kech_Q_xp(j) + ywake_s(j)*dd_KQp
1664	Kech_Up(j) = Kech_U_xp(j) + ywake_s(j)*dd_KUp
1665	Kech_Vp(j) = Kech_V_xp(j) + ywake_s(j)*dd_KVp
1666	!
1667	! Calcul des differences w-x
1668	dd_CM = ycdragm_w(j) - ycdragm_x(j)
1669	dd_CH = ycdragh_w(j) - ycdragh_x(j)
1670	dd_u = yu_w(j,1) - yu_x(j,1)
1671	dd_v = yv_w(j,1) - yv_x(j,1)
1672	dd_t = yt_w(j,1) - yt_x(j,1)
1673	dd_q = yq_w(j,1) - yq_x(j,1)
1674	dd_AH = AcoefH_w(j) - AcoefH_x(j)
1675	dd_AQ = AcoefQ_w(j) - AcoefQ_x(j)
1676	dd_AU = AcoefU_w(j) - AcoefU_x(j)
1677	dd_AV = AcoefV_w(j) - AcoefV_x(j)
1678	dd_BH = BcoefH_w(j) - BcoefH_x(j)
1679	dd_BQ = BcoefQ_w(j) - BcoefQ_x(j)
1680	dd_BU = BcoefU_w(j) - BcoefU_x(j)
1681	dd_BV = BcoefV_w(j) - BcoefV_x(j)
1682	!
1683	IF (prt_level >=10) THEN
1684	print *,'Variables pour la fusion : Kech_H_xp(j)' ,Kech_H_xp(j)
1685	print *,'Variables pour la fusion : Kech_H_wp(j)' ,Kech_H_wp(j)
1686	print *,'Variables pour la fusion : Kech_Hp(j)' ,Kech_Hp(j)
1687	print *,'Variables pour la fusion : Kech_h(j)' ,Kech_h(j)
1688	ENDIF
1689	!
1690	! Calcul des coef A, B \'equivalents dans la couche 1
1691	!
1692	AcoefH(j) = AcoefH_x(j) + ywake_s(j)(Kech_H_wp(j)/Kech_Hp(j))dd_AH
1693	AcoefQ(j) = AcoefQ_x(j) + ywake_s(j)(Kech_Q_wp(j)/Kech_Qp(j))dd_AQ
1694	AcoefU(j) = AcoefU_x(j) + ywake_s(j)(Kech_U_wp(j)/Kech_Up(j))dd_AU
1695	AcoefV(j) = AcoefV_x(j) + ywake_s(j)(Kech_V_wp(j)/Kech_Vp(j))dd_AV
1696	!
1697	BcoefH(j) = BcoefH_x(j) + ywake_s(j)BcoefH_x(j)(dd_Kh/Kech_h(j))*(1.+Kech_H_wp(j)/Kech_Hp(j)) &
1698	+ ywake_s(j)(Kech_H_wp(j)/Kech_Hp(j))(Kech_h_w(j)/Kech_h(j))*dd_BH
1699
1700	BcoefQ(j) = BcoefQ_x(j) + ywake_s(j)BcoefQ_x(j)(dd_Kh/Kech_h(j))*(1.+Kech_Q_wp(j)/Kech_Qp(j)) &
1701	+ ywake_s(j)(Kech_Q_wp(j)/Kech_Qp(j))(Kech_h_w(j)/Kech_h(j))*dd_BQ
1702
1703	BcoefU(j) = BcoefU_x(j) + ywake_s(j)BcoefU_x(j)(dd_Km/Kech_h(j))*(1.+Kech_U_wp(j)/Kech_Up(j)) &
1704	+ ywake_s(j)(Kech_U_wp(j)/Kech_Up(j))(Kech_m_w(j)/Kech_m(j))*dd_BU
1705
1706	BcoefV(j) = BcoefV_x(j) + ywake_s(j)BcoefV_x(j)(dd_Km/Kech_h(j))*(1.+Kech_V_wp(j)/Kech_Vp(j)) &
1707	+ ywake_s(j)(Kech_V_wp(j)/Kech_Vp(j))(Kech_m_w(j)/Kech_m(j))*dd_BV
1708
1709	!
1710	! Calcul des cdrag \'equivalents dans la couche
1711	!
1712	ycdragm(j) = ycdragm_x(j) + ywake_s(j)*dd_CM
1713	ycdragh(j) = ycdragh_x(j) + ywake_s(j)*dd_CH
1714	!
1715	! Calcul de T, q, u et v \'equivalents dans la couche 1
1716	yt(j,1) = yt_x(j,1) + ywake_s(j)(Kech_h_w(j)/Kech_h(j))dd_t
1717	yq(j,1) = yq_x(j,1) + ywake_s(j)(Kech_h_w(j)/Kech_h(j))dd_q
1718	yu(j,1) = yu_x(j,1) + ywake_s(j)(Kech_m_w(j)/Kech_m(j))dd_u
1719	yv(j,1) = yv_x(j,1) + ywake_s(j)(Kech_m_w(j)/Kech_m(j))dd_v
1720
1721
1722	ENDDO
1723	!!!
1724	ENDIF ! (iflag_split .eq.1)
1725	!!!
1726
1727	!****************************************************************************************
1728	!
1729	! Calulate t2m and q2m for the case of calculation at land grid points
1730	! t2m and q2m are needed as input to ORCHIDEE
1731	!
1732	!****************************************************************************************
1733	IF (nsrf == is_ter) THEN
1734
1735	DO i = 1, knon
1736	zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
1737	* (ypaprs(i,1)-ypplay(i,1))
1738	END DO
1739
1740	! Calculate the temperature et relative humidity at 2m and the wind at 10m
1741	CALL stdlevvar(klon, knon, is_ter, zxli, &
1742	yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, &
1743	yts, yqsurf, yz0m, yz0h, ypaprs(:,1), ypplay(:,1), &
1744	yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
1745
1746	END IF
1747
1748	!****************************************************************************************
1749	!
1750	! 10) Switch according to current surface
1751	! It is necessary to start with the continental surfaces because the ocean
1752	! needs their run-off.
1753	!
1754	!****************************************************************************************
1755	SELECT CASE(nsrf)
1756
1757	CASE(is_ter)
1758	! print*,"DEBUGTS",yts(knon/2),ylwdown(knon/2)
1759	CALL surf_land(itap, dtime, date0, jour, knon, ni,&
1760	rlon, rlat, yrmu0, &
1761	debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, &
1762	yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
1763	AcoefH, AcoefQ, BcoefH, BcoefQ, &
1764	AcoefU, AcoefV, BcoefU, BcoefV, &
1765	ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
1766	ylwdown, yq2m, yt2m, &
1767	ysnow, yqsol, yagesno, ytsoil, &
1768	yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
1769	yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
1770	y_flux_u1, y_flux_v1 )
1771
1772	! Special DICE MPL 05082013 puis BOMEX
1773	IF (ok_prescr_ust) THEN
1774	do j=1,knon
1775	! ysnow(:)=0.
1776	! yqsol(:)=0.
1777	! yagesno(:)=50.
1778	! ytsoil(:,:)=300.
1779	! yz0_new(:)=0.001
1780	! yevap(:)=flat/RLVTT
1781	! yfluxlat(:)=-flat
1782	! yfluxsens(:)=-fsens
1783	! yqsurf(:)=0.
1784	! ytsurf_new(:)=tg
1785	! y_dflux_t(:)=0.
1786	! y_dflux_q(:)=0.
1787	y_flux_u1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yu(j,1)*ypplay(j,1)/RD/yt(j,1)
1788	y_flux_v1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yv(j,1)*ypplay(j,1)/RD/yt(j,1)
1789	enddo
1790	ENDIF
1791
1792
1793	CASE(is_lic)
1794	! Martin
1795	CALL surf_landice(itap, dtime, knon, ni, &
1796	rlon, rlat, debut, lafin, &
1797	yrmu0, ylwdown, yalb, ypphi(:,1), &
1798	ysolsw, ysollw, yts, ypplay(:,1), &
1799	ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
1800	AcoefH, AcoefQ, BcoefH, BcoefQ, &
1801	AcoefU, AcoefV, BcoefU, BcoefV, &
1802	ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
1803	ysnow, yqsurf, yqsol, yagesno, &
1804	ytsoil, yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap,yfluxsens,yfluxlat, &
1805	ytsurf_new, y_dflux_t, y_dflux_q, &
1806	yzsig, ycldt, &
1807	ysnowhgt, yqsnow, ytoice, ysissnow, &
1808	yalb3_new, yrunoff, &
1809	y_flux_u1, y_flux_v1)
1810
1811	!jyg<
1812	!! alb3_lic(:)=0.
1813	!>jyg
1814	DO j = 1, knon
1815	i = ni(j)
1816	alb3_lic(i) = yalb3_new(j)
1817	snowhgt(i) = ysnowhgt(j)
1818	qsnow(i) = yqsnow(j)
1819	to_ice(i) = ytoice(j)
1820	sissnow(i) = ysissnow(j)
1821	runoff(i) = yrunoff(j)
1822	END DO
1823	! Martin
1824	! Special DICE MPL 05082013 puis BOMEX MPL 20150410
1825	IF (ok_prescr_ust) THEN
1826	DO j=1,knon
1827	y_flux_u1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yu(j,1)*ypplay(j,1)/RD/yt(j,1)
1828	y_flux_v1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yv(j,1)*ypplay(j,1)/RD/yt(j,1)
1829	ENDDO
1830	ENDIF
1831
1832	CASE(is_oce)
1833	CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb_vis, &
1834	ywindsp, rmu0, yfder, yts, &
1835	itap, dtime, jour, knon, ni, &
1836	ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
1837	AcoefH, AcoefQ, BcoefH, BcoefQ, &
1838	AcoefU, AcoefV, BcoefU, BcoefV, &
1839	ypsref, yu1, yv1, ygustiness, yrugoro, pctsrf, &
1840	ysnow, yqsurf, yagesno, &
1841	yz0m, yz0h, SFRWL,yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
1842	ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, &
1843	y_flux_u1, y_flux_v1)
1844	IF (prt_level >=10) THEN
1845	print *,'arg de surf_ocean: ycdragh ',ycdragh
1846	print *,'arg de surf_ocean: ycdragm ',ycdragm
1847	print *,'arg de surf_ocean: yt ', yt
1848	print *,'arg de surf_ocean: yq ', yq
1849	print *,'arg de surf_ocean: yts ', yts
1850	print *,'arg de surf_ocean: AcoefH ',AcoefH
1851	print *,'arg de surf_ocean: AcoefQ ',AcoefQ
1852	print *,'arg de surf_ocean: BcoefH ',BcoefH
1853	print *,'arg de surf_ocean: BcoefQ ',BcoefQ
1854	print *,'arg de surf_ocean: yevap ',yevap
1855	print *,'arg de surf_ocean: yfluxsens ',yfluxsens
1856	print *,'arg de surf_ocean: yfluxlat ',yfluxlat
1857	print *,'arg de surf_ocean: ytsurf_new ',ytsurf_new
1858	ENDIF
1859	! Special DICE MPL 05082013 puis BOMEX MPL 20150410
1860	IF (ok_prescr_ust) THEN
1861	DO j=1,knon
1862	y_flux_u1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yu(j,1)*ypplay(j,1)/RD/yt(j,1)
1863	y_flux_v1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yv(j,1)*ypplay(j,1)/RD/yt(j,1)
1864	ENDDO
1865	ENDIF
1866
1867	CASE(is_sic)
1868	CALL surf_seaice( &
1869	!albedo SB >>>
1870	rlon, rlat, ysolsw, ysollw, yalb_vis, yfder, &
1871	!albedo SB <<<
1872	itap, dtime, jour, knon, ni, &
1873	lafin, &
1874	yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
1875	AcoefH, AcoefQ, BcoefH, BcoefQ, &
1876	AcoefU, AcoefV, BcoefU, BcoefV, &
1877	ypsref, yu1, yv1, ygustiness, pctsrf, &
1878	ysnow, yqsurf, yqsol, yagesno, ytsoil, &
1879	!albedo SB >>>
1880	yz0m, yz0h, SFRWL, yalb_dir_new, yalb_dif_new, yevap, yfluxsens,yfluxlat,&
1881	!albedo SB <<<
1882	ytsurf_new, y_dflux_t, y_dflux_q, &
1883	y_flux_u1, y_flux_v1)
1884
1885	! Special DICE MPL 05082013 puis BOMEX MPL 20150410
1886	IF (ok_prescr_ust) THEN
1887	DO j=1,knon
1888	y_flux_u1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yu(j,1)*ypplay(j,1)/RD/yt(j,1)
1889	y_flux_v1(j)=ycdragm(j)(1.+sqrt(yu(j,1)yu(j,1)+yv(j,1)yv(j,1)))yv(j,1)*ypplay(j,1)/RD/yt(j,1)
1890	ENDDO
1891	ENDIF
1892
1893	CASE DEFAULT
1894	WRITE(lunout,*) 'Surface index = ', nsrf
1895	abort_message = 'Surface index not valid'
1896	CALL abort_physic(modname,abort_message,1)
1897	END SELECT
1898
1899
1900	!****************************************************************************************
1901	! 11) - Calcul the increment of surface temperature
1902	!
1903	!****************************************************************************************
1904
1905	if (evap0>=0.) then
1906	yevap(:)=evap0
1907	yevap(:)=RLVTT*evap0
1908	endif
1909
1910
1911	y_d_ts(1:knon) = ytsurf_new(1:knon) - yts(1:knon)
1912
1913	!****************************************************************************************
1914	!
1915	! 12) "La remontee" - "The uphill"
1916	!
1917	! The fluxes (y_flux_X) and tendancy (y_d_X) are calculated
1918	! for X=H, Q, U and V, for all vertical levels.
1919	!
1920	!****************************************************************************************
1921
1922	!!!
1923	!!! jyg le 10/04/2013
1924	!!!
1925	IF (ok_flux_surf) THEN
1926	IF (prt_level >=10) THEN
1927	PRINT *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT
1928	ENDIF
1929	y_flux_t1(:) = fsens
1930	y_flux_q1(:) = flat/RLVTT
1931	yfluxlat(:) = flat
1932	!
1933	IF (iflag_split .eq.0) THEN
1934	do j=1,knon
1935	Kech_h(j) = ycdragh(j) * (1.0+SQRT(yu(j,1)2+yv(j,1)2)) * &
1936	ypplay(j,1)/(RD*yt(j,1))
1937	enddo
1938	ENDIF ! (iflag_split .eq.0)
1939
1940	DO j = 1, knon
1941	yt1_new=(1./RCPD)(AcoefH(j)+BcoefH(j)y_flux_t1(j)*dtime)
1942	ytsurf_new(j)=yt1_new-y_flux_t1(j)/(Kech_h(j)*RCPD)
1943	ENDDO
1944
1945	do j=1,knon
1946	y_d_ts(j) = ytsurf_new(j) - yts(j)
1947	enddo
1948
1949	ELSE ! (ok_flux_surf)
1950	do j=1,knon
1951	y_flux_t1(j) = yfluxsens(j)
1952	y_flux_q1(j) = -yevap(j)
1953	enddo
1954	ENDIF
1955
1956	IF (prt_level >=10) THEN
1957	DO j=1,knon
1958	print*,'y_flux_t1,yfluxlat,wakes' &
1959	& , y_flux_t1(j), yfluxlat(j), ywake_s(j)
1960	print*,'beta,ytsurf_new', ybeta(j), ytsurf_new(j)
1961	print*,'effusivity,facteur,cstar', effusivity, facteur,wake_cstar(j)
1962	ENDDO
1963	ENDIF
1964
1965	!!! jyg le 07/02/2012 puis le 10/04/2013
1966	IF (iflag_split .eq.1) THEN
1967	!!!
1968	DO j=1,knon
1969	y_delta_flux_t1(j) = ( Kech_H_wp(j)Kech_H_xp(j)(AcoefH_w(j)-AcoefH_x(j)) + &
1970	y_flux_t1(j)*(Kech_H_wp(j)-Kech_H_xp(j)) ) / Kech_Hp(j)
1971	y_delta_flux_q1(j) = ( Kech_Q_wp(j)Kech_Q_xp(j)(AcoefQ_w(j)-AcoefQ_x(j)) + &
1972	y_flux_q1(j)*(Kech_Q_wp(j)-Kech_Q_xp(j)) ) / Kech_Qp(j)
1973	y_delta_flux_u1(j) = ( Kech_U_wp(j)Kech_U_xp(j)(AcoefU_w(j)-AcoefU_x(j)) + &
1974	y_flux_u1(j)*(Kech_U_wp(j)-Kech_U_xp(j)) ) / Kech_Up(j)
1975	y_delta_flux_v1(j) = ( Kech_V_wp(j)Kech_V_xp(j)(AcoefV_w(j)-AcoefV_x(j)) + &
1976	y_flux_v1(j)*(Kech_V_wp(j)-Kech_V_xp(j)) ) / Kech_Vp(j)
1977	!
1978	y_flux_t1_x(j)=y_flux_t1(j) - ywake_s(j)*y_delta_flux_t1(j)
1979	y_flux_t1_w(j)=y_flux_t1(j) + (1.-ywake_s(j))*y_delta_flux_t1(j)
1980	y_flux_q1_x(j)=y_flux_q1(j) - ywake_s(j)*y_delta_flux_q1(j)
1981	y_flux_q1_w(j)=y_flux_q1(j) + (1.-ywake_s(j))*y_delta_flux_q1(j)
1982	y_flux_u1_x(j)=y_flux_u1(j) - ywake_s(j)*y_delta_flux_u1(j)
1983	y_flux_u1_w(j)=y_flux_u1(j) + (1.-ywake_s(j))*y_delta_flux_u1(j)
1984	y_flux_v1_x(j)=y_flux_v1(j) - ywake_s(j)*y_delta_flux_v1(j)
1985	y_flux_v1_w(j)=y_flux_v1(j) + (1.-ywake_s(j))*y_delta_flux_v1(j)
1986	!
1987	yfluxlat_x(j)=y_flux_q1_x(j)*RLVTT
1988	yfluxlat_w(j)=y_flux_q1_w(j)*RLVTT
1989
1990	ENDDO
1991	!
1992
1993	!!jyg!! A reprendre apres reflexion ===============================================
1994	!!jyg!!
1995	!!jyg!! DO j=1,knon
1996	!!jyg!!!!! nrlmd le 13/06/2011
1997	!!jyg!!
1998	!!jyg!!!----Diffusion dans le sol dans le cas continental seulement
1999	!!jyg!! IF (nsrf.eq.is_ter) THEN
2000	!!jyg!!!----Calcul du coefficient delta_coeff
2001	!!jyg!! tau_eq(j)=(ywake_s(j)/2.)(1./max(wake_cstar(j),0.01))sqrt(0.4/(3.14*max(wake_dens(j),8e-12)))
2002	!!jyg!!
2003	!!jyg!!! delta_coef(j)=dtime/(effusivity*sqrt(tau_eq(j)))
2004	!!jyg!! delta_coef(j)=facteur*sqrt(tau_eq(j))/effusivity
2005	!!jyg!!! delta_coef(j)=0.
2006	!!jyg!! ELSE
2007	!!jyg!! delta_coef(j)=0.
2008	!!jyg!! ENDIF
2009	!!jyg!!
2010	!!jyg!!!----Calcul de delta_tsurf
2011	!!jyg!! y_delta_tsurf(j)=delta_coef(j)*y_delta_flux_t1(j)
2012	!!jyg!!
2013	!!jyg!!!----Si il n'y a pas des poches...
2014	!!jyg!! IF (wake_cstar(j).le.0.01) THEN
2015	!!jyg!! y_delta_tsurf(j)=0.
2016	!!jyg!! y_delta_flux_t1(j)=0.
2017	!!jyg!! ENDIF
2018	!!jyg!!
2019	!!jyg!!!-----Calcul de ybeta (evap_r\'eelle/evap_potentielle)
2020	!!jyg!!!!!!! jyg le 23/02/2012
2021	!!jyg!!!!!!!
2022	!!jyg!!!! ybeta(j)=y_flux_q1(j) / &
2023	!!jyg!!!! & (Kech_h(j)*(yq(j,1)-yqsatsurf(j)))
2024	!!jyg!!!!!! ybeta(j)=-1.*yevap(j) / &
2025	!!jyg!!!!!! & (ywake_s(j)Kech_h_w(j)(yq_w(j,1)-yqsatsurf_w(j))+(1.-ywake_s(j))Kech_h_x(j)(yq_x(j,1)-yqsatsurf_x(j)))
2026	!!jyg!!!!!!! fin jyg
2027	!!jyg!!!!!
2028	!!jyg!!
2029	!!jyg!! ENDDO
2030	!!jyg!!
2031	!!jyg!!!!! fin nrlmd le 13/06/2011
2032	!!jyg!!
2033	IF (prt_level >=10) THEN
2034	DO j = 1, knon
2035	print*,'Chx,Chw,Ch', ycdragh_x(j), ycdragh_w(j), ycdragh(j)
2036	print*,'Khx,Khw,Kh', Kech_h_x(j), Kech_h_w(j), Kech_h(j)
2037	! print*,'tsurf_x,tsurf_w,tsurf,t1', ytsurf_th_x(j), ytsurf_th_w(j), ytsurf_th(j), yt(j,1)
2038	print*,'tsurf_x,t1x,tsurf_w,t1w,tsurf,t1,t1_ancien', &
2039	& ytsurf_th_x(j), yt_x(j,1), ytsurf_th_w(j), yt_w(j,1), ytsurf_th(j), yt(j,1),t(j,1)
2040	print*,'qsatsurf,qsatsurf_x,qsatsurf_w', yqsatsurf(j), yqsatsurf_x(j), yqsatsurf_w(j)
2041	print*,'delta_coef,delta_flux,delta_tsurf,tau', delta_coef(j), y_delta_flux_t1(j), y_delta_tsurf(j), tau_eq(j)
2042	ENDDO
2043
2044	DO j=1,knon
2045	print*,'fluxT_x, fluxT_w, y_flux_t1, fluxQ_x, fluxQ_w, yfluxlat, wakes' &
2046	& , y_flux_t1_x(j), y_flux_t1_w(j), y_flux_t1(j), y_flux_q1_x(j)RLVTT, y_flux_q1_w(j)RLVTT, yfluxlat(j), ywake_s(j)
2047	print*,'beta,ytsurf_new,yqsatsurf', ybeta(j), ytsurf_new(j), yqsatsurf(j)
2048	print*,'effusivity,facteur,cstar', effusivity, facteur,wake_cstar(j)
2049	ENDDO
2050	ENDIF ! (prt_level >=10)
2051
2052	!!! jyg le 07/02/2012
2053	ENDIF ! (iflag_split .eq.1)
2054	!!!
2055
2056	!!! jyg le 07/02/2012
2057	IF (iflag_split .eq.0) THEN
2058	!!!
2059	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
2060	CALL climb_hq_up(knon, dtime, yt, yq, &
2061	y_flux_q1, y_flux_t1, ypaprs, ypplay, &
2062	!!! jyg le 07/02/2012
2063	AcoefH, AcoefQ, BcoefH, BcoefQ, &
2064	CcoefH, CcoefQ, DcoefH, DcoefQ, &
2065	Kcoef_hq, gama_q, gama_h, &
2066	!!!
2067	y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))
2068	ELSE !(iflag_split .eq.0)
2069	CALL climb_hq_up(knon, dtime, yt_x, yq_x, &
2070	y_flux_q1_x, y_flux_t1_x, ypaprs, ypplay, &
2071	!!! nrlmd le 02/05/2011
2072	AcoefH_x, AcoefQ_x, BcoefH_x, BcoefQ_x, &
2073	CcoefH_x, CcoefQ_x, DcoefH_x, DcoefQ_x, &
2074	Kcoef_hq_x, gama_q_x, gama_h_x, &
2075	!!!
2076	y_flux_q_x(:,:), y_flux_t_x(:,:), y_d_q_x(:,:), y_d_t_x(:,:))
2077	!
2078	CALL climb_hq_up(knon, dtime, yt_w, yq_w, &
2079	y_flux_q1_w, y_flux_t1_w, ypaprs, ypplay, &
2080	!!! nrlmd le 02/05/2011
2081	AcoefH_w, AcoefQ_w, BcoefH_w, BcoefQ_w, &
2082	CcoefH_w, CcoefQ_w, DcoefH_w, DcoefQ_w, &
2083	Kcoef_hq_w, gama_q_w, gama_h_w, &
2084	!!!
2085	y_flux_q_w(:,:), y_flux_t_w(:,:), y_d_q_w(:,:), y_d_t_w(:,:))
2086	!!!
2087	ENDIF ! (iflag_split .eq.0)
2088	!!!
2089
2090	!!! jyg le 07/02/2012
2091	IF (iflag_split .eq.0) THEN
2092	!!!
2093	!!! nrlmd & jyg les 02/05/2011, 13/06/2011, 05/02/2012
2094	CALL climb_wind_up(knon, dtime, yu, yv, y_flux_u1, y_flux_v1, &
2095	!!! jyg le 07/02/2012
2096	AcoefU, AcoefV, BcoefU, BcoefV, &
2097	CcoefU, CcoefV, DcoefU, DcoefV, &
2098	Kcoef_m, &
2099	!!!
2100	y_flux_u, y_flux_v, y_d_u, y_d_v)
2101	y_d_t_diss(:,:)=0.
2102	IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN
2103	CALL yamada_c(knon,dtime,ypaprs,ypplay &
2104	& ,yu,yv,yt,y_d_u,y_d_v,y_d_t,ycdragm,ytke,ycoefm,ycoefh,ycoefq,y_d_t_diss,yustar &
2105	& ,iflag_pbl)
2106	ENDIF
2107	! print*,'yamada_c OK'
2108
2109	ELSE !(iflag_split .eq.0)
2110	CALL climb_wind_up(knon, dtime, yu_x, yv_x, y_flux_u1_x, y_flux_v1_x, &
2111	!!! nrlmd le 02/05/2011
2112	AcoefU_x, AcoefV_x, BcoefU_x, BcoefV_x, &
2113	CcoefU_x, CcoefV_x, DcoefU_x, DcoefV_x, &
2114	Kcoef_m_x, &
2115	!!!
2116	y_flux_u_x, y_flux_v_x, y_d_u_x, y_d_v_x)
2117	!
2118	y_d_t_diss_x(:,:)=0.
2119	IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN
2120	CALL yamada_c(knon,dtime,ypaprs,ypplay &
2121	& ,yu_x,yv_x,yt_x,y_d_u_x,y_d_v_x,y_d_t_x,ycdragm_x,ytke_x,ycoefm_x,ycoefh_x &
2122	,ycoefq_x,y_d_t_diss_x,yustar_x &
2123	& ,iflag_pbl)
2124	ENDIF
2125	! print*,'yamada_c OK'
2126
2127	CALL climb_wind_up(knon, dtime, yu_w, yv_w, y_flux_u1_w, y_flux_v1_w, &
2128	!!! nrlmd le 02/05/2011
2129	AcoefU_w, AcoefV_w, BcoefU_w, BcoefV_w, &
2130	CcoefU_w, CcoefV_w, DcoefU_w, DcoefV_w, &
2131	Kcoef_m_w, &
2132	!!!
2133	y_flux_u_w, y_flux_v_w, y_d_u_w, y_d_v_w)
2134	!!!
2135	y_d_t_diss_w(:,:)=0.
2136	IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN
2137	CALL yamada_c(knon,dtime,ypaprs,ypplay &
2138	& ,yu_w,yv_w,yt_w,y_d_u_w,y_d_v_w,y_d_t_w,ycdragm_w,ytke_w,ycoefm_w,ycoefh_w &
2139	,ycoefq_w,y_d_t_diss_w,yustar_w &
2140	& ,iflag_pbl)
2141	ENDIF
2142	! print*,'yamada_c OK'
2143	!
2144	IF (prt_level >=10) THEN
2145	print *, 'After climbing up, lfuxlat_x, fluxlat_w ', &
2146	yfluxlat_x, yfluxlat_w
2147	ENDIF
2148	!
2149	ENDIF ! (iflag_split .eq.0)
2150	!!!
2151
2152	DO j = 1, knon
2153	y_dflux_t(j) = y_dflux_t(j) * ypct(j)
2154	y_dflux_q(j) = y_dflux_q(j) * ypct(j)
2155	ENDDO
2156
2157	!****************************************************************************************
2158	! 13) Transform variables for output format :
2159	! - Decompress
2160	! - Multiply with pourcentage of current surface
2161	! - Cumulate in global variable
2162	!
2163	!****************************************************************************************
2164
2165
2166	!!! jyg le 07/02/2012
2167	IF (iflag_split .eq.0) THEN
2168	!!!
2169	DO k = 1, klev
2170	DO j = 1, knon
2171	i = ni(j)
2172	y_d_t_diss(j,k) = y_d_t_diss(j,k) * ypct(j)
2173	y_d_t(j,k) = y_d_t(j,k) * ypct(j)
2174	y_d_q(j,k) = y_d_q(j,k) * ypct(j)
2175	y_d_u(j,k) = y_d_u(j,k) * ypct(j)
2176	y_d_v(j,k) = y_d_v(j,k) * ypct(j)
2177
2178	flux_t(i,k,nsrf) = y_flux_t(j,k)
2179	flux_q(i,k,nsrf) = y_flux_q(j,k)
2180	flux_u(i,k,nsrf) = y_flux_u(j,k)
2181	flux_v(i,k,nsrf) = y_flux_v(j,k)
2182
2183
2184	ENDDO
2185	ENDDO
2186
2187
2188	ELSE !(iflag_split .eq.0)
2189
2190	! Tendances hors poches
2191	DO k = 1, klev
2192	DO j = 1, knon
2193	i = ni(j)
2194	y_d_t_diss_x(j,k) = y_d_t_diss_x(j,k) * ypct(j)
2195	y_d_t_x(j,k) = y_d_t_x(j,k) * ypct(j)
2196	y_d_q_x(j,k) = y_d_q_x(j,k) * ypct(j)
2197	y_d_u_x(j,k) = y_d_u_x(j,k) * ypct(j)
2198	y_d_v_x(j,k) = y_d_v_x(j,k) * ypct(j)
2199
2200	flux_t_x(i,k,nsrf) = y_flux_t_x(j,k)
2201	flux_q_x(i,k,nsrf) = y_flux_q_x(j,k)
2202	flux_u_x(i,k,nsrf) = y_flux_u_x(j,k)
2203	flux_v_x(i,k,nsrf) = y_flux_v_x(j,k)
2204	ENDDO
2205	ENDDO
2206
2207	! Tendances dans les poches
2208	DO k = 1, klev
2209	DO j = 1, knon
2210	i = ni(j)
2211	y_d_t_diss_w(j,k) = y_d_t_diss_w(j,k) * ypct(j)
2212	y_d_t_w(j,k) = y_d_t_w(j,k) * ypct(j)
2213	y_d_q_w(j,k) = y_d_q_w(j,k) * ypct(j)
2214	y_d_u_w(j,k) = y_d_u_w(j,k) * ypct(j)
2215	y_d_v_w(j,k) = y_d_v_w(j,k) * ypct(j)
2216
2217	flux_t_w(i,k,nsrf) = y_flux_t_w(j,k)
2218	flux_q_w(i,k,nsrf) = y_flux_q_w(j,k)
2219	flux_u_w(i,k,nsrf) = y_flux_u_w(j,k)
2220	flux_v_w(i,k,nsrf) = y_flux_v_w(j,k)
2221	ENDDO
2222	ENDDO
2223
2224	! Flux, tendances et Tke moyenne dans la maille
2225	DO k = 1, klev
2226	DO j = 1, knon
2227	i = ni(j)
2228	flux_t(i,k,nsrf) = flux_t_x(i,k,nsrf)+ywake_s(j)*(flux_t_w(i,k,nsrf)-flux_t_x(i,k,nsrf))
2229	flux_q(i,k,nsrf) = flux_q_x(i,k,nsrf)+ywake_s(j)*(flux_q_w(i,k,nsrf)-flux_q_x(i,k,nsrf))
2230	flux_u(i,k,nsrf) = flux_u_x(i,k,nsrf)+ywake_s(j)*(flux_u_w(i,k,nsrf)-flux_u_x(i,k,nsrf))
2231	flux_v(i,k,nsrf) = flux_v_x(i,k,nsrf)+ywake_s(j)*(flux_v_w(i,k,nsrf)-flux_v_x(i,k,nsrf))
2232	ENDDO
2233	ENDDO
2234	DO j=1,knon
2235	yfluxlat(j)=yfluxlat_x(j)+ywake_s(j)*(yfluxlat_w(j)-yfluxlat_x(j))
2236	ENDDO
2237	IF (prt_level >=10) THEN
2238	print *,' nsrf, flux_t(:,1,nsrf), flux_t_x(:,1,nsrf), flux_t_w(:,1,nsrf) ', &
2239	nsrf, flux_t(:,1,nsrf), flux_t_x(:,1,nsrf), flux_t_w(:,1,nsrf)
2240	ENDIF
2241
2242	DO k = 1, klev
2243	DO j = 1, knon
2244	y_d_t_diss(j,k) = y_d_t_diss_x(j,k)+ywake_s(j)*(y_d_t_diss_w(j,k) -y_d_t_diss_x(j,k))
2245	y_d_t(j,k) = y_d_t_x(j,k)+ywake_s(j)*(y_d_t_w(j,k) -y_d_t_x(j,k))
2246	y_d_q(j,k) = y_d_q_x(j,k)+ywake_s(j)*(y_d_q_w(j,k) -y_d_q_x(j,k))
2247	y_d_u(j,k) = y_d_u_x(j,k)+ywake_s(j)*(y_d_u_w(j,k) -y_d_u_x(j,k))
2248	y_d_v(j,k) = y_d_v_x(j,k)+ywake_s(j)*(y_d_v_w(j,k) -y_d_v_x(j,k))
2249	ENDDO
2250	ENDDO
2251
2252	ENDIF ! (iflag_split .eq.0)
2253	!!!
2254
2255	! print*,'Dans pbl OK1'
2256
2257	!jyg<
2258	!! evap(:,nsrf) = - flux_q(:,1,nsrf)
2259	!>jyg
2260	DO j = 1, knon
2261	i = ni(j)
2262	evap(i,nsrf) = - flux_q(i,1,nsrf) !jyg
2263	d_ts(i,nsrf) = y_d_ts(j)
2264	!albedo SB >>>
2265	do k=1,nsw
2266	alb_dir(i,k,nsrf) = yalb_dir_new(j,k)
2267	alb_dif(i,k,nsrf) = yalb_dif_new(j,k)
2268	enddo
2269	!albedo SB <<<
2270	snow(i,nsrf) = ysnow(j)
2271	qsurf(i,nsrf) = yqsurf(j)
2272	z0m(i,nsrf) = yz0m(j)
2273	z0h(i,nsrf) = yz0h(j)
2274	fluxlat(i,nsrf) = yfluxlat(j)
2275	agesno(i,nsrf) = yagesno(j)
2276	cdragh(i) = cdragh(i) + ycdragh(j)*ypct(j)
2277	cdragm(i) = cdragm(i) + ycdragm(j)*ypct(j)
2278	dflux_t(i) = dflux_t(i) + y_dflux_t(j)
2279	dflux_q(i) = dflux_q(i) + y_dflux_q(j)
2280	END DO
2281
2282	! print*,'Dans pbl OK2'
2283
2284	!!! jyg le 07/02/2012
2285	IF (iflag_split .ge.1) THEN
2286	!!!
2287	!!! nrlmd le 02/05/2011
2288	DO j = 1, knon
2289	i = ni(j)
2290	fluxlat_x(i,nsrf) = yfluxlat_x(j)
2291	fluxlat_w(i,nsrf) = yfluxlat_w(j)
2292	!!!
2293	!!! nrlmd le 13/06/2011
2294	delta_tsurf(i,nsrf)=y_delta_tsurf(j)*ypct(j)
2295	cdragh_x(i) = cdragh_x(i) + ycdragh_x(j)*ypct(j)
2296	cdragh_w(i) = cdragh_w(i) + ycdragh_w(j)*ypct(j)
2297	cdragm_x(i) = cdragm_x(i) + ycdragm_x(j)*ypct(j)
2298	cdragm_w(i) = cdragm_w(i) + ycdragm_w(j)*ypct(j)
2299	kh(i) = kh(i) + Kech_h(j)*ypct(j)
2300	kh_x(i) = kh_x(i) + Kech_h_x(j)*ypct(j)
2301	kh_w(i) = kh_w(i) + Kech_h_w(j)*ypct(j)
2302	!!!
2303	END DO
2304	!!!
2305	ENDIF ! (iflag_split .ge.1)
2306	!!!
2307	!!! nrlmd le 02/05/2011
2308	!!jyg le 20/02/2011
2309	!! tke_x(:,:,nsrf)=0.
2310	!! tke_w(:,:,nsrf)=0.
2311	!!jyg le 20/02/2011
2312	!! DO k = 1, klev+1
2313	!! DO j = 1, knon
2314	!! i = ni(j)
2315	!! wake_dltke(i,k,nsrf) = ytke_w(j,k) - ytke_x(j,k)
2316	!! tke(i,k,nsrf) = ytke_x(j,k) + ywake_s(j)*wake_dltke(i,k,nsrf)
2317	!! ENDDO
2318	!! ENDDO
2319	!!jyg le 20/02/2011
2320	!! DO k = 1, klev+1
2321	!! DO j = 1, knon
2322	!! i = ni(j)
2323	!! tke(i,k,nsrf)=(1.-ywake_s(j))tke_x(i,k,nsrf)+ywake_s(j)tke_w(i,k,nsrf)
2324	!! ENDDO
2325	!! ENDDO
2326	!!!
2327	IF (iflag_split .eq.0) THEN
2328	DO k = 1, klev
2329	DO j = 1, knon
2330	i = ni(j)
2331	!jyg<
2332	!! tke(i,k,nsrf) = ytke(j,k)
2333	!! tke(i,k,is_ave) = tke(i,k,is_ave) + ytke(j,k)*ypct(j)
2334	tke_x(i,k,nsrf) = ytke(j,k)
2335	tke_x(i,k,is_ave) = tke_x(i,k,is_ave) + ytke(j,k)*ypct(j)
2336	!>jyg
2337	END DO
2338	END DO
2339
2340	ELSE ! (iflag_split .eq.0)
2341	DO k = 1, klev
2342	DO j = 1, knon
2343	i = ni(j)
2344	wake_dltke(i,k,nsrf) = ytke_w(j,k) - ytke_x(j,k)
2345	!jyg<
2346	!! tke(i,k,nsrf) = ytke_x(j,k) + ywake_s(j)*wake_dltke(i,k,nsrf)
2347	!! tke(i,k,is_ave) = tke(i,k,is_ave) + tke(i,k,nsrf)*ypct(j)
2348	tke_x(i,k,nsrf) = ytke_x(j,k)
2349	tke_x(i,k,is_ave) = tke_x(i,k,is_ave) + tke_x(i,k,nsrf)*ypct(j)
2350	wake_dltke(i,k,is_ave) = wake_dltke(i,k,is_ave) + wake_dltke(i,k,nsrf)*ypct(j)
2351
2352	!>jyg
2353	ENDDO
2354	ENDDO
2355	ENDIF ! (iflag_split .eq.0)
2356	!!!
2357	DO k = 2, klev
2358	DO j = 1, knon
2359	i = ni(j)
2360	zcoefh(i,k,nsrf) = ycoefh(j,k)
2361	zcoefm(i,k,nsrf) = ycoefm(j,k)
2362	zcoefh(i,k,is_ave) = zcoefh(i,k,is_ave) + ycoefh(j,k)*ypct(j)
2363	zcoefm(i,k,is_ave) = zcoefm(i,k,is_ave) + ycoefm(j,k)*ypct(j)
2364	END DO
2365	END DO
2366
2367	! print*,'Dans pbl OK3'
2368
2369	IF ( nsrf .EQ. is_ter ) THEN
2370	DO j = 1, knon
2371	i = ni(j)
2372	qsol(i) = yqsol(j)
2373	END DO
2374	END IF
2375
2376	!jyg<
2377	!! ftsoil(:,:,nsrf) = 0.
2378	!>jyg
2379	DO k = 1, nsoilmx
2380	DO j = 1, knon
2381	i = ni(j)
2382	ftsoil(i, k, nsrf) = ytsoil(j,k)
2383	END DO
2384	END DO
2385
2386	!!! jyg le 07/02/2012
2387	IF (iflag_split .ge.1) THEN
2388	!!!
2389	!!! nrlmd+jyg le 02/05/2011 et le 20/02/2012
2390	DO k = 1, klev
2391	DO j = 1, knon
2392	i = ni(j)
2393	d_t_diss_x(i,k) = d_t_diss_x(i,k) + y_d_t_diss_x(j,k)
2394	d_t_x(i,k) = d_t_x(i,k) + y_d_t_x(j,k)
2395	d_q_x(i,k) = d_q_x(i,k) + y_d_q_x(j,k)
2396	d_u_x(i,k) = d_u_x(i,k) + y_d_u_x(j,k)
2397	d_v_x(i,k) = d_v_x(i,k) + y_d_v_x(j,k)
2398	!
2399	d_t_diss_w(i,k) = d_t_diss_w(i,k) + y_d_t_diss_w(j,k)
2400	d_t_w(i,k) = d_t_w(i,k) + y_d_t_w(j,k)
2401	d_q_w(i,k) = d_q_w(i,k) + y_d_q_w(j,k)
2402	d_u_w(i,k) = d_u_w(i,k) + y_d_u_w(j,k)
2403	d_v_w(i,k) = d_v_w(i,k) + y_d_v_w(j,k)
2404	!
2405	!! d_wake_dlt(i,k) = d_wake_dlt(i,k) + y_d_t_w(i,k)-y_d_t_x(i,k)
2406	!! d_wake_dlq(i,k) = d_wake_dlq(i,k) + y_d_q_w(i,k)-y_d_q_x(i,k)
2407	END DO
2408	END DO
2409	!!!
2410	ENDIF ! (iflag_split .ge.1)
2411	!!!
2412
2413	DO k = 1, klev
2414	DO j = 1, knon
2415	i = ni(j)
2416	d_t_diss(i,k) = d_t_diss(i,k) + y_d_t_diss(j,k)
2417	d_t(i,k) = d_t(i,k) + y_d_t(j,k)
2418	d_q(i,k) = d_q(i,k) + y_d_q(j,k)
2419	d_u(i,k) = d_u(i,k) + y_d_u(j,k)
2420	d_v(i,k) = d_v(i,k) + y_d_v(j,k)
2421	END DO
2422	END DO
2423
2424	! print*,'Dans pbl OK4'
2425
2426	IF (prt_level >=10) THEN
2427	print *, 'pbl_surface tendencies for w: d_t_w, d_t_x, d_t ', &
2428	d_t_w(:,1), d_t_x(:,1), d_t(:,1)
2429	ENDIF
2430
2431	!****************************************************************************************
2432	! 14) Calculate the temperature and relative humidity at 2m and the wind at 10m
2433	! Call HBTM
2434	!
2435	!****************************************************************************************
2436	!!!
2437	!
2438	#undef T2m
2439	#define T2m
2440	#ifdef T2m
2441	! Calculations of diagnostic t,q at 2m and u, v at 10m
2442
2443	! print*,'Dans pbl OK41'
2444	! print*,'tair1,yt(:,1),y_d_t(:,1)'
2445	! print*, tair1,yt(:,1),y_d_t(:,1)
2446	!!! jyg le 07/02/2012
2447	IF (iflag_split .eq.0) THEN
2448	DO j=1, knon
2449	uzon(j) = yu(j,1) + y_d_u(j,1)
2450	vmer(j) = yv(j,1) + y_d_v(j,1)
2451	tair1(j) = yt(j,1) + y_d_t(j,1) + y_d_t_diss(j,1)
2452	qair1(j) = yq(j,1) + y_d_q(j,1)
2453	zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
2454	* (ypaprs(j,1)-ypplay(j,1))
2455	tairsol(j) = yts(j) + y_d_ts(j)
2456	qairsol(j) = yqsurf(j)
2457	END DO
2458	ELSE ! (iflag_split .eq.0)
2459	DO j=1, knon
2460	uzon_x(j) = yu_x(j,1) + y_d_u_x(j,1)
2461	vmer_x(j) = yv_x(j,1) + y_d_v_x(j,1)
2462	tair1_x(j) = yt_x(j,1) + y_d_t_x(j,1) + y_d_t_diss_x(j,1)
2463	qair1_x(j) = yq_x(j,1) + y_d_q_x(j,1)
2464	zgeo1_x(j) = RD * tair1_x(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
2465	* (ypaprs(j,1)-ypplay(j,1))
2466	tairsol(j) = yts(j) + y_d_ts(j)
2467	tairsol_x(j) = tairsol(j) - ywake_s(j)*y_delta_tsurf(j)
2468	qairsol(j) = yqsurf(j)
2469	END DO
2470	DO j=1, knon
2471	uzon_w(j) = yu_w(j,1) + y_d_u_w(j,1)
2472	vmer_w(j) = yv_w(j,1) + y_d_v_w(j,1)
2473	tair1_w(j) = yt_w(j,1) + y_d_t_w(j,1) + y_d_t_diss_w(j,1)
2474	qair1_w(j) = yq_w(j,1) + y_d_q_w(j,1)
2475	zgeo1_w(j) = RD * tair1_w(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
2476	* (ypaprs(j,1)-ypplay(j,1))
2477	tairsol_w(j) = tairsol(j) + (1.- ywake_s(j))*y_delta_tsurf(j)
2478	qairsol(j) = yqsurf(j)
2479	END DO
2480	!!!
2481	ENDIF ! (iflag_split .eq.0)
2482	!!!
2483	DO j=1, knon
2484	i = ni(j)
2485	rugo1(j) = yz0m(j)
2486	IF(nsrf.EQ.is_oce) THEN
2487	rugo1(j) = z0m(i,nsrf)
2488	ENDIF
2489	psfce(j)=ypaprs(j,1)
2490	patm(j)=ypplay(j,1)
2491	END DO
2492
2493	! print*,'Dans pbl OK42A'
2494	! print*,'tair1,yt(:,1),y_d_t(:,1)'
2495	! print*, tair1,yt(:,1),y_d_t(:,1)
2496
2497	! Calculate the temperature et relative humidity at 2m and the wind at 10m
2498	!!! jyg le 07/02/2012
2499	IF (iflag_split .eq.0) THEN
2500	CALL stdlevvar(klon, knon, nsrf, zxli, &
2501	uzon, vmer, tair1, qair1, zgeo1, &
2502	tairsol, qairsol, rugo1, rugo1, psfce, patm, &
2503	yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
2504	ELSE !(iflag_split .eq.0)
2505	CALL stdlevvar(klon, knon, nsrf, zxli, &
2506	uzon_x, vmer_x, tair1_x, qair1_x, zgeo1_x, &
2507	tairsol_x, qairsol, rugo1, rugo1, psfce, patm, &
2508	yt2m_x, yq2m_x, yt10m_x, yq10m_x, yu10m_x, yustar_x)
2509	CALL stdlevvar(klon, knon, nsrf, zxli, &
2510	uzon_w, vmer_w, tair1_w, qair1_w, zgeo1_w, &
2511	tairsol_w, qairsol, rugo1, rugo1, psfce, patm, &
2512	yt2m_w, yq2m_w, yt10m_w, yq10m_w, yu10m_w, yustar_w)
2513	!!!
2514	ENDIF ! (iflag_split .eq.0)
2515	!!!
2516	!!! jyg le 07/02/2012
2517	IF (iflag_split .eq.0) THEN
2518	DO j=1, knon
2519	i = ni(j)
2520	t2m(i,nsrf)=yt2m(j)
2521	q2m(i,nsrf)=yq2m(j)
2522	! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
2523	ustar(i,nsrf)=yustar(j)
2524	u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)2+vmer(j)2)
2525	v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)2+vmer(j)2)
2526	END DO
2527	ELSE !(iflag_split .eq.0)
2528	DO j=1, knon
2529	i = ni(j)
2530	t2m_x(i,nsrf)=yt2m_x(j)
2531	q2m_x(i,nsrf)=yq2m_x(j)
2532	! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
2533	ustar_x(i,nsrf)=yustar_x(j)
2534	u10m_x(i,nsrf)=(yu10m_x(j) * uzon_x(j))/SQRT(uzon_x(j)2+vmer_x(j)2)
2535	v10m_x(i,nsrf)=(yu10m_x(j) * vmer_x(j))/SQRT(uzon_x(j)2+vmer_x(j)2)
2536	END DO
2537	DO j=1, knon
2538	i = ni(j)
2539	t2m_w(i,nsrf)=yt2m_w(j)
2540	q2m_w(i,nsrf)=yq2m_w(j)
2541	! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
2542	ustar_w(i,nsrf)=yustar_w(j)
2543	u10m_w(i,nsrf)=(yu10m_w(j) * uzon_w(j))/SQRT(uzon_w(j)2+vmer_w(j)2)
2544	v10m_w(i,nsrf)=(yu10m_w(j) * vmer_w(j))/SQRT(uzon_w(j)2+vmer_w(j)2)
2545	!
2546	ustar(i,nsrf) = ustar_x(i,nsrf) + wake_s(i)*(ustar_w(i,nsrf)-ustar_x(i,nsrf))
2547	u10m(i,nsrf) = u10m_x(i,nsrf) + wake_s(i)*(u10m_w(i,nsrf)-u10m_x(i,nsrf))
2548	v10m(i,nsrf) = v10m_x(i,nsrf) + wake_s(i)*(v10m_w(i,nsrf)-v10m_x(i,nsrf))
2549	END DO
2550	!!!
2551	ENDIF ! (iflag_split .eq.0)
2552	!!!
2553
2554	! print*,'Dans pbl OK43'
2555	!IM Calcule de l'humidite relative a 2m (rh2m) pour diagnostique
2556	!IM Ajoute dependance type surface
2557	IF (thermcep) THEN
2558	!!! jyg le 07/02/2012
2559	IF (iflag_split .eq.0) THEN
2560	DO j = 1, knon
2561	i=ni(j)
2562	zdelta1 = MAX(0.,SIGN(1., rtt-yt2m(j) ))
2563	zx_qs1 = r2es * FOEEW(yt2m(j),zdelta1)/paprs(i,1)
2564	zx_qs1 = MIN(0.5,zx_qs1)
2565	zcor1 = 1./(1.-RETV*zx_qs1)
2566	zx_qs1 = zx_qs1*zcor1
2567
2568	rh2m(i) = rh2m(i) + yq2m(j)/zx_qs1 * pctsrf(i,nsrf)
2569	qsat2m(i) = qsat2m(i) + zx_qs1 * pctsrf(i,nsrf)
2570	END DO
2571	ELSE ! (iflag_split .eq.0)
2572	DO j = 1, knon
2573	i=ni(j)
2574	zdelta1 = MAX(0.,SIGN(1., rtt-yt2m_x(j) ))
2575	zx_qs1 = r2es * FOEEW(yt2m_x(j),zdelta1)/paprs(i,1)
2576	zx_qs1 = MIN(0.5,zx_qs1)
2577	zcor1 = 1./(1.-RETV*zx_qs1)
2578	zx_qs1 = zx_qs1*zcor1
2579
2580	rh2m_x(i) = rh2m_x(i) + yq2m_x(j)/zx_qs1 * pctsrf(i,nsrf)
2581	qsat2m_x(i) = qsat2m_x(i) + zx_qs1 * pctsrf(i,nsrf)
2582	END DO
2583	DO j = 1, knon
2584	i=ni(j)
2585	zdelta1 = MAX(0.,SIGN(1., rtt-yt2m_w(j) ))
2586	zx_qs1 = r2es * FOEEW(yt2m_w(j),zdelta1)/paprs(i,1)
2587	zx_qs1 = MIN(0.5,zx_qs1)
2588	zcor1 = 1./(1.-RETV*zx_qs1)
2589	zx_qs1 = zx_qs1*zcor1
2590
2591	rh2m_w(i) = rh2m_w(i) + yq2m_w(j)/zx_qs1 * pctsrf(i,nsrf)
2592	qsat2m_w(i) = qsat2m_w(i) + zx_qs1 * pctsrf(i,nsrf)
2593	END DO
2594	!!!
2595	ENDIF ! (iflag_split .eq.0)
2596	!!!
2597	END IF
2598	!
2599	IF (prt_level >=10) THEN
2600	print *, 'T2m, q2m, RH2m ', &
2601	t2m, q2m, rh2m
2602	ENDIF
2603
2604	! print*,'OK pbl 5'
2605	!
2606	!!! jyg le 07/02/2012
2607	IF (iflag_split .eq.0) THEN
2608	CALL hbtm(knon, ypaprs, ypplay, &
2609	yt2m,yt10m,yq2m,yq10m,yustar,ywstar, &
2610	y_flux_t,y_flux_q,yu,yv,yt,yq, &
2611	ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, &
2612	ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
2613	IF (prt_level >=10) THEN
2614	print *,' Arg. de HBTM: yt2m ',yt2m
2615	print *,' Arg. de HBTM: yt10m ',yt10m
2616	print *,' Arg. de HBTM: yq2m ',yq2m
2617	print *,' Arg. de HBTM: yq10m ',yq10m
2618	print *,' Arg. de HBTM: yustar ',yustar
2619	print *,' Arg. de HBTM: y_flux_t ',y_flux_t
2620	print *,' Arg. de HBTM: y_flux_q ',y_flux_q
2621	print *,' Arg. de HBTM: yu ',yu
2622	print *,' Arg. de HBTM: yv ',yv
2623	print *,' Arg. de HBTM: yt ',yt
2624	print *,' Arg. de HBTM: yq ',yq
2625	ENDIF
2626	ELSE ! (iflag_split .eq.0)
2627	CALL HBTM(knon, ypaprs, ypplay, &
2628	yt2m_x,yt10m_x,yq2m_x,yq10m_x,yustar_x,ywstar_x, &
2629	y_flux_t_x,y_flux_q_x,yu_x,yv_x,yt_x,yq_x, &
2630	ypblh_x,ycapCL_x,yoliqCL_x,ycteiCL_x,ypblT_x, &
2631	ytherm_x,ytrmb1_x,ytrmb2_x,ytrmb3_x,ylcl_x)
2632	IF (prt_level >=10) THEN
2633	print *,' Arg. de HBTM: yt2m_x ',yt2m_x
2634	print *,' Arg. de HBTM: yt10m_x ',yt10m_x
2635	print *,' Arg. de HBTM: yq2m_x ',yq2m_x
2636	print *,' Arg. de HBTM: yq10m_x ',yq10m_x
2637	print *,' Arg. de HBTM: yustar_x ',yustar_x
2638	print *,' Arg. de HBTM: y_flux_t_x ',y_flux_t_x
2639	print *,' Arg. de HBTM: y_flux_q_x ',y_flux_q_x
2640	print *,' Arg. de HBTM: yu_x ',yu_x
2641	print *,' Arg. de HBTM: yv_x ',yv_x
2642	print *,' Arg. de HBTM: yt_x ',yt_x
2643	print *,' Arg. de HBTM: yq_x ',yq_x
2644	ENDIF
2645	CALL HBTM(knon, ypaprs, ypplay, &
2646	yt2m_w,yt10m_w,yq2m_w,yq10m_w,yustar_w,ywstar_w, &
2647	y_flux_t_w,y_flux_q_w,yu_w,yv_w,yt_w,yq_w, &
2648	ypblh_w,ycapCL_w,yoliqCL_w,ycteiCL_w,ypblT_w, &
2649	ytherm_w,ytrmb1_w,ytrmb2_w,ytrmb3_w,ylcl_w)
2650	!!!
2651	ENDIF ! (iflag_split .eq.0)
2652	!!!
2653
2654	!!! jyg le 07/02/2012
2655	IF (iflag_split .eq.0) THEN
2656	!!!
2657	DO j=1, knon
2658	i = ni(j)
2659	pblh(i,nsrf) = ypblh(j)
2660	wstar(i,nsrf) = ywstar(j)
2661	plcl(i,nsrf) = ylcl(j)
2662	capCL(i,nsrf) = ycapCL(j)
2663	oliqCL(i,nsrf) = yoliqCL(j)
2664	cteiCL(i,nsrf) = ycteiCL(j)
2665	pblT(i,nsrf) = ypblT(j)
2666	therm(i,nsrf) = ytherm(j)
2667	trmb1(i,nsrf) = ytrmb1(j)
2668	trmb2(i,nsrf) = ytrmb2(j)
2669	trmb3(i,nsrf) = ytrmb3(j)
2670	END DO
2671	IF (prt_level >=10) THEN
2672	print *, 'After HBTM: pblh ', pblh
2673	print *, 'After HBTM: plcl ', plcl
2674	print *, 'After HBTM: cteiCL ', cteiCL
2675	ENDIF
2676	ELSE !(iflag_split .eq.0)
2677	DO j=1, knon
2678	i = ni(j)
2679	pblh_x(i,nsrf) = ypblh_x(j)
2680	wstar_x(i,nsrf) = ywstar_x(j)
2681	plcl_x(i,nsrf) = ylcl_x(j)
2682	capCL_x(i,nsrf) = ycapCL_x(j)
2683	oliqCL_x(i,nsrf) = yoliqCL_x(j)
2684	cteiCL_x(i,nsrf) = ycteiCL_x(j)
2685	pblT_x(i,nsrf) = ypblT_x(j)
2686	therm_x(i,nsrf) = ytherm_x(j)
2687	trmb1_x(i,nsrf) = ytrmb1_x(j)
2688	trmb2_x(i,nsrf) = ytrmb2_x(j)
2689	trmb3_x(i,nsrf) = ytrmb3_x(j)
2690	END DO
2691	IF (prt_level >=10) THEN
2692	print *, 'After HBTM: pblh_x ', pblh_x
2693	print *, 'After HBTM: plcl_x ', plcl_x
2694	print *, 'After HBTM: cteiCL_x ', cteiCL_x
2695	ENDIF
2696	DO j=1, knon
2697	i = ni(j)
2698	pblh_w(i,nsrf) = ypblh_w(j)
2699	wstar_w(i,nsrf) = ywstar_w(j)
2700	plcl_w(i,nsrf) = ylcl_w(j)
2701	capCL_w(i,nsrf) = ycapCL_w(j)
2702	oliqCL_w(i,nsrf) = yoliqCL_w(j)
2703	cteiCL_w(i,nsrf) = ycteiCL_w(j)
2704	pblT_w(i,nsrf) = ypblT_w(j)
2705	therm_w(i,nsrf) = ytherm_w(j)
2706	trmb1_w(i,nsrf) = ytrmb1_w(j)
2707	trmb2_w(i,nsrf) = ytrmb2_w(j)
2708	trmb3_w(i,nsrf) = ytrmb3_w(j)
2709	END DO
2710	IF (prt_level >=10) THEN
2711	print *, 'After HBTM: pblh_w ', pblh_w
2712	print *, 'After HBTM: plcl_w ', plcl_w
2713	print *, 'After HBTM: cteiCL_w ', cteiCL_w
2714	ENDIF
2715	!!!
2716	ENDIF ! (iflag_split .eq.0)
2717	!!!
2718
2719	! print*,'OK pbl 6'
2720	#else
2721	! T2m not defined
2722	! No calculation
2723	PRINT*,' Warning !!! No T2m calculation. Output is set to zero.'
2724	#endif
2725
2726	!****************************************************************************************
2727	! 15) End of loop over different surfaces
2728	!
2729	!****************************************************************************************
2730	END DO loop_nbsrf
2731
2732	!****************************************************************************************
2733	! 16) Calculate the mean value over all sub-surfaces for some variables
2734	!
2735	!****************************************************************************************
2736
2737	z0m(:,nbsrf+1) = 0.0
2738	z0h(:,nbsrf+1) = 0.0
2739	DO nsrf = 1, nbsrf
2740	DO i = 1, klon
2741	z0m(i,nbsrf+1) = z0m(i,nbsrf+1) + z0m(i,nsrf)*pctsrf(i,nsrf)
2742	z0h(i,nbsrf+1) = z0h(i,nbsrf+1) + z0h(i,nsrf)*pctsrf(i,nsrf)
2743	ENDDO
2744	ENDDO
2745
2746	! print*,'OK pbl 7'
2747	zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
2748	zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0
2749	zxfluxt_x(:,:) = 0.0 ; zxfluxq_x(:,:) = 0.0
2750	zxfluxu_x(:,:) = 0.0 ; zxfluxv_x(:,:) = 0.0
2751	zxfluxt_w(:,:) = 0.0 ; zxfluxq_w(:,:) = 0.0
2752	zxfluxu_w(:,:) = 0.0 ; zxfluxv_w(:,:) = 0.0
2753
2754	!!! jyg le 07/02/2012
2755	IF (iflag_split .ge.1) THEN
2756	!!!
2757	!!! nrlmd & jyg les 02/05/2011, 05/02/2012
2758
2759	DO nsrf = 1, nbsrf
2760	DO k = 1, klev
2761	DO i = 1, klon
2762	zxfluxt_x(i,k) = zxfluxt_x(i,k) + flux_t_x(i,k,nsrf) * pctsrf(i,nsrf)
2763	zxfluxq_x(i,k) = zxfluxq_x(i,k) + flux_q_x(i,k,nsrf) * pctsrf(i,nsrf)
2764	zxfluxu_x(i,k) = zxfluxu_x(i,k) + flux_u_x(i,k,nsrf) * pctsrf(i,nsrf)
2765	zxfluxv_x(i,k) = zxfluxv_x(i,k) + flux_v_x(i,k,nsrf) * pctsrf(i,nsrf)
2766	!
2767	zxfluxt_w(i,k) = zxfluxt_w(i,k) + flux_t_w(i,k,nsrf) * pctsrf(i,nsrf)
2768	zxfluxq_w(i,k) = zxfluxq_w(i,k) + flux_q_w(i,k,nsrf) * pctsrf(i,nsrf)
2769	zxfluxu_w(i,k) = zxfluxu_w(i,k) + flux_u_w(i,k,nsrf) * pctsrf(i,nsrf)
2770	zxfluxv_w(i,k) = zxfluxv_w(i,k) + flux_v_w(i,k,nsrf) * pctsrf(i,nsrf)
2771	END DO
2772	END DO
2773	END DO
2774
2775	DO i = 1, klon
2776	zxsens_x(i) = - zxfluxt_x(i,1)
2777	zxsens_w(i) = - zxfluxt_w(i,1)
2778	END DO
2779	!!!
2780	ENDIF ! (iflag_split .ge.1)
2781	!!!
2782
2783	DO nsrf = 1, nbsrf
2784	DO k = 1, klev
2785	DO i = 1, klon
2786	zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf(i,nsrf)
2787	zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf(i,nsrf)
2788	zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf)
2789	zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf)
2790	END DO
2791	END DO
2792	END DO
2793
2794	DO i = 1, klon
2795	zxsens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol
2796	zxevap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol
2797	fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i)
2798	ENDDO
2799	!!!
2800
2801	!
2802	! Incrementer la temperature du sol
2803	!
2804	zxtsol(:) = 0.0 ; zxfluxlat(:) = 0.0
2805	zt2m(:) = 0.0 ; zq2m(:) = 0.0
2806	zustar(:)=0.0 ; zu10m(:) = 0.0 ; zv10m(:) = 0.0
2807	s_pblh(:) = 0.0 ; s_plcl(:) = 0.0
2808	!!! jyg le 07/02/2012
2809	s_pblh_x(:) = 0.0 ; s_plcl_x(:) = 0.0
2810	s_pblh_w(:) = 0.0 ; s_plcl_w(:) = 0.0
2811	!!!
2812	s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0
2813	s_cteiCL(:) = 0.0; s_pblT(:) = 0.0
2814	s_therm(:) = 0.0 ; s_trmb1(:) = 0.0
2815	s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0
2816	wstar(:,is_ave)=0.
2817
2818	! print*,'OK pbl 9'
2819
2820	!!! nrlmd le 02/05/2011
2821	zxfluxlat_x(:) = 0.0 ; zxfluxlat_w(:) = 0.0
2822	!!!
2823
2824	DO nsrf = 1, nbsrf
2825	DO i = 1, klon
2826	ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf)
2827
2828	wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) &
2829	+ flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf)
2830	wfbilo(i,nsrf) = (evap(i,nsrf)-(rain_f(i)+snow_f(i)))*pctsrf(i,nsrf)
2831	wfevap(i,nsrf) = evap(i,nsrf)*pctsrf(i,nsrf)
2832	wfrain(i,nsrf) = rain_f(i)*pctsrf(i,nsrf)
2833	wfsnow(i,nsrf) = snow_f(i)*pctsrf(i,nsrf)
2834
2835	zxtsol(i) = zxtsol(i) + ts(i,nsrf) * pctsrf(i,nsrf)
2836	zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf(i,nsrf)
2837	END DO
2838	END DO
2839	!
2840	!<al1 order 2 correction to zxtsol, for radiation computations (main atm effect of Ts)
2841	IF (iflag_order2_sollw == 1) THEN
2842	meansqT(:) = 0. ! as working buffer
2843	DO nsrf = 1, nbsrf
2844	DO i = 1, klon
2845	meansqT(i) = meansqT(i)+(ts(i,nsrf)-zxtsol(i))*2 pctsrf(i,nsrf)
2846	END DO
2847	END DO
2848	zxtsol(:) = zxtsol(:)+1.5*meansqT(:)/zxtsol(:)
2849	ENDIF ! iflag_order2_sollw == 1
2850	!>al1
2851
2852	!!! jyg le 07/02/2012
2853	IF (iflag_split .eq.0) THEN
2854	DO nsrf = 1, nbsrf
2855	DO i = 1, klon
2856	zt2m(i) = zt2m(i) + t2m(i,nsrf) * pctsrf(i,nsrf)
2857	zq2m(i) = zq2m(i) + q2m(i,nsrf) * pctsrf(i,nsrf)
2858	zustar(i) = zustar(i) + ustar(i,nsrf) * pctsrf(i,nsrf)
2859	wstar(i,is_ave)=wstar(i,is_ave)+wstar(i,nsrf)*pctsrf(i,nsrf)
2860	zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf(i,nsrf)
2861	zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf(i,nsrf)
2862
2863	s_pblh(i) = s_pblh(i) + pblh(i,nsrf) * pctsrf(i,nsrf)
2864	s_plcl(i) = s_plcl(i) + plcl(i,nsrf) * pctsrf(i,nsrf)
2865	s_capCL(i) = s_capCL(i) + capCL(i,nsrf) * pctsrf(i,nsrf)
2866	s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf(i,nsrf)
2867	s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf(i,nsrf)
2868	s_pblT(i) = s_pblT(i) + pblT(i,nsrf) * pctsrf(i,nsrf)
2869	s_therm(i) = s_therm(i) + therm(i,nsrf) * pctsrf(i,nsrf)
2870	s_trmb1(i) = s_trmb1(i) + trmb1(i,nsrf) * pctsrf(i,nsrf)
2871	s_trmb2(i) = s_trmb2(i) + trmb2(i,nsrf) * pctsrf(i,nsrf)
2872	s_trmb3(i) = s_trmb3(i) + trmb3(i,nsrf) * pctsrf(i,nsrf)
2873	END DO
2874	END DO
2875	ELSE !(iflag_split .eq.0)
2876	DO nsrf = 1, nbsrf
2877	DO i = 1, klon
2878	!!! nrlmd le 02/05/2011
2879	zxfluxlat_x(i) = zxfluxlat_x(i) + fluxlat_x(i,nsrf) * pctsrf(i,nsrf)
2880	zxfluxlat_w(i) = zxfluxlat_w(i) + fluxlat_w(i,nsrf) * pctsrf(i,nsrf)
2881	!!!
2882	!!! jyg le 08/02/2012
2883	!! Pour le moment, on sort les valeurs dans (x) et (w) de pblh et de plcl ;
2884	!! pour zt2m, on fait la moyenne surfacique sur les sous-surfaces ;
2885	!! pour qsat2m, on fait la moyenne surfacique sur (x) et (w) ;
2886	!! pour les autres variables, on sort les valeurs de la region (x).
2887	zt2m(i) = zt2m(i) + (t2m_x(i,nsrf)+wake_s(i)(t2m_w(i,nsrf)-t2m_x(i,nsrf))) pctsrf(i,nsrf)
2888	zq2m(i) = zq2m(i) + q2m_x(i,nsrf) * pctsrf(i,nsrf)
2889	zustar(i) = zustar(i) + ustar_x(i,nsrf) * pctsrf(i,nsrf)
2890	wstar(i,is_ave)=wstar(i,is_ave)+wstar_x(i,nsrf)*pctsrf(i,nsrf)
2891	zu10m(i) = zu10m(i) + u10m_x(i,nsrf) * pctsrf(i,nsrf)
2892	zv10m(i) = zv10m(i) + v10m_x(i,nsrf) * pctsrf(i,nsrf)
2893	!
2894	s_pblh(i) = s_pblh(i) + pblh_x(i,nsrf) * pctsrf(i,nsrf)
2895	s_pblh_x(i) = s_pblh_x(i) + pblh_x(i,nsrf) * pctsrf(i,nsrf)
2896	s_pblh_w(i) = s_pblh_w(i) + pblh_w(i,nsrf) * pctsrf(i,nsrf)
2897	!
2898	s_plcl(i) = s_plcl(i) + plcl_x(i,nsrf) * pctsrf(i,nsrf)
2899	s_plcl_x(i) = s_plcl_x(i) + plcl_x(i,nsrf) * pctsrf(i,nsrf)
2900	s_plcl_w(i) = s_plcl_w(i) + plcl_w(i,nsrf) * pctsrf(i,nsrf)
2901	!
2902	s_capCL(i) = s_capCL(i) + capCL_x(i,nsrf) * pctsrf(i,nsrf)
2903	s_oliqCL(i) = s_oliqCL(i) + oliqCL_x(i,nsrf)* pctsrf(i,nsrf)
2904	s_cteiCL(i) = s_cteiCL(i) + cteiCL_x(i,nsrf)* pctsrf(i,nsrf)
2905	s_pblT(i) = s_pblT(i) + pblT_x(i,nsrf) * pctsrf(i,nsrf)
2906	s_therm(i) = s_therm(i) + therm_x(i,nsrf) * pctsrf(i,nsrf)
2907	s_trmb1(i) = s_trmb1(i) + trmb1_x(i,nsrf) * pctsrf(i,nsrf)
2908	s_trmb2(i) = s_trmb2(i) + trmb2_x(i,nsrf) * pctsrf(i,nsrf)
2909	s_trmb3(i) = s_trmb3(i) + trmb3_x(i,nsrf) * pctsrf(i,nsrf)
2910	END DO
2911	END DO
2912	DO i = 1, klon
2913	qsat2m(i)= qsat2m_x(i)+ wake_s(i)*(qsat2m_x(i)-qsat2m_w(i))
2914	END DO
2915	!!!
2916	ENDIF ! (iflag_split .eq.0)
2917	!!!
2918
2919	IF (check) THEN
2920	amn=MIN(ts(1,is_ter),1000.)
2921	amx=MAX(ts(1,is_ter),-1000.)
2922	DO i=2, klon
2923	amn=MIN(ts(i,is_ter),amn)
2924	amx=MAX(ts(i,is_ter),amx)
2925	ENDDO
2926	PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx
2927	ENDIF
2928
2929	!jg ?
2930	!!$!
2931	!!$! If a sub-surface does not exsist for a grid point, the mean value for all
2932	!!$! sub-surfaces is distributed.
2933	!!$!
2934	!!$ DO nsrf = 1, nbsrf
2935	!!$ DO i = 1, klon
2936	!!$ IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN
2937	!!$ ts(i,nsrf) = zxtsol(i)
2938	!!$ t2m(i,nsrf) = zt2m(i)
2939	!!$ q2m(i,nsrf) = zq2m(i)
2940	!!$ u10m(i,nsrf) = zu10m(i)
2941	!!$ v10m(i,nsrf) = zv10m(i)
2942	!!$
2943	!!$! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour
2944	!!$ pblh(i,nsrf) = s_pblh(i)
2945	!!$ plcl(i,nsrf) = s_plcl(i)
2946	!!$ capCL(i,nsrf) = s_capCL(i)
2947	!!$ oliqCL(i,nsrf) = s_oliqCL(i)
2948	!!$ cteiCL(i,nsrf) = s_cteiCL(i)
2949	!!$ pblT(i,nsrf) = s_pblT(i)
2950	!!$ therm(i,nsrf) = s_therm(i)
2951	!!$ trmb1(i,nsrf) = s_trmb1(i)
2952	!!$ trmb2(i,nsrf) = s_trmb2(i)
2953	!!$ trmb3(i,nsrf) = s_trmb3(i)
2954	!!$ ENDIF
2955	!!$ ENDDO
2956	!!$ ENDDO
2957
2958
2959	DO i = 1, klon
2960	fder(i) = - 4.0RSIGMAzxtsol(i)**3
2961	ENDDO
2962
2963	zxqsurf(:) = 0.0
2964	zxsnow(:) = 0.0
2965	DO nsrf = 1, nbsrf
2966	DO i = 1, klon
2967	zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf(i,nsrf)
2968	zxsnow(i) = zxsnow(i) + snow(i,nsrf) * pctsrf(i,nsrf)
2969	END DO
2970	END DO
2971
2972	! Premier niveau de vent sortie dans physiq.F
2973	zu1(:) = u(:,1)
2974	zv1(:) = v(:,1)
2975
2976
2977	END SUBROUTINE pbl_surface
2978	!
2979	!****************************************************************************************
2980	!
2981	SUBROUTINE pbl_surface_final(fder_rst, snow_rst, qsurf_rst, ftsoil_rst)
2982
2983	USE indice_sol_mod
2984
2985	INCLUDE "dimsoil.h"
2986
2987	! Ouput variables
2988	!****************************************************************************************
2989	REAL, DIMENSION(klon), INTENT(OUT) :: fder_rst
2990	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: snow_rst
2991	REAL, DIMENSION(klon, nbsrf), INTENT(OUT) :: qsurf_rst
2992	REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst
2993
2994
2995	!****************************************************************************************
2996	! Return module variables for writing to restart file
2997	!
2998	!****************************************************************************************
2999	fder_rst(:) = fder(:)
3000	snow_rst(:,:) = snow(:,:)
3001	qsurf_rst(:,:) = qsurf(:,:)
3002	ftsoil_rst(:,:,:) = ftsoil(:,:,:)
3003
3004	!****************************************************************************************
3005	! Deallocate module variables
3006	!
3007	!****************************************************************************************
3008	! DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
3009	IF (ALLOCATED(fder)) DEALLOCATE(fder)
3010	IF (ALLOCATED(snow)) DEALLOCATE(snow)
3011	IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf)
3012	IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil)
3013
3014	END SUBROUTINE pbl_surface_final
3015	!
3016	!****************************************************************************************
3017	!
3018
3019	!albedo SB >>>
3020	SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, &
3021	evap, z0m, z0h, agesno, &
3022	tsurf,alb_dir,alb_dif, ustar, u10m, v10m, tke)
3023	!albedo SB <<<
3024	! Give default values where new fraction has appread
3025
3026	USE indice_sol_mod
3027
3028	INCLUDE "dimsoil.h"
3029	INCLUDE "clesphys.h"
3030	INCLUDE "compbl.h"
3031
3032	! Input variables
3033	!****************************************************************************************
3034	INTEGER, INTENT(IN) :: itime
3035	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf_new, pctsrf_old
3036
3037	! InOutput variables
3038	!****************************************************************************************
3039	REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
3040	!albedo SB >>>
3041	REAL, DIMENSION(klon,nsw,nbsrf), INTENT(INOUT) :: alb_dir, alb_dif
3042	INTEGER :: k
3043	!albedo SB <<<
3044	REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar,u10m, v10m
3045	REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: evap, agesno
3046	REAL, DIMENSION(klon,nbsrf+1), INTENT(INOUT) :: z0m,z0h
3047	REAL, DIMENSION(klon,klev+1,nbsrf+1), INTENT(INOUT) :: tke
3048
3049	! Local variables
3050	!****************************************************************************************
3051	INTEGER :: nsrf, nsrf_comp1, nsrf_comp2, nsrf_comp3, i
3052	CHARACTER(len=80) :: abort_message
3053	CHARACTER(len=20) :: modname = 'pbl_surface_newfrac'
3054	INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0
3055	!
3056	! All at once !!
3057	!****************************************************************************************
3058
3059	DO nsrf = 1, nbsrf
3060	! First decide complement sub-surfaces
3061	SELECT CASE (nsrf)
3062	CASE(is_oce)
3063	nsrf_comp1=is_sic
3064	nsrf_comp2=is_ter
3065	nsrf_comp3=is_lic
3066	CASE(is_sic)
3067	nsrf_comp1=is_oce
3068	nsrf_comp2=is_ter
3069	nsrf_comp3=is_lic
3070	CASE(is_ter)
3071	nsrf_comp1=is_lic
3072	nsrf_comp2=is_oce
3073	nsrf_comp3=is_sic
3074	CASE(is_lic)
3075	nsrf_comp1=is_ter
3076	nsrf_comp2=is_oce
3077	nsrf_comp3=is_sic
3078	END SELECT
3079
3080	! Initialize all new fractions
3081	DO i=1, klon
3082	IF (pctsrf_new(i,nsrf) > 0. .AND. pctsrf_old(i,nsrf) == 0.) THEN
3083
3084	IF (pctsrf_old(i,nsrf_comp1) > 0.) THEN
3085	! Use the complement sub-surface, keeping the continents unchanged
3086	qsurf(i,nsrf) = qsurf(i,nsrf_comp1)
3087	evap(i,nsrf) = evap(i,nsrf_comp1)
3088	z0m(i,nsrf) = z0m(i,nsrf_comp1)
3089	z0h(i,nsrf) = z0h(i,nsrf_comp1)
3090	tsurf(i,nsrf) = tsurf(i,nsrf_comp1)
3091	!albedo SB >>>
3092	DO k=1,nsw
3093	alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp1)
3094	alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp1)
3095	ENDDO
3096	!albedo SB <<<
3097	ustar(i,nsrf) = ustar(i,nsrf_comp1)
3098	u10m(i,nsrf) = u10m(i,nsrf_comp1)
3099	v10m(i,nsrf) = v10m(i,nsrf_comp1)
3100	if (iflag_pbl > 1) then
3101	tke(i,:,nsrf) = tke(i,:,nsrf_comp1)
3102	endif
3103	mfois(nsrf) = mfois(nsrf) + 1
3104	! F. Codron sensible default values for ocean and sea ice
3105	IF (nsrf.EQ.is_oce) THEN
3106	tsurf(i,nsrf) = 271.35 ! Freezing sea water
3107	DO k=1,nsw
3108	alb_dir(i,k,nsrf) = 0.06 ! typical Ocean albedo
3109	alb_dif(i,k,nsrf) = 0.06
3110	END DO
3111	ELSE IF (nsrf.EQ.is_sic) THEN
3112	tsurf(i,nsrf) = 273.15 ! Melting ice
3113	DO k=1,nsw
3114	alb_dir(i,k,nsrf) = 0.3 ! thin ice
3115	alb_dif(i,k,nsrf) = 0.3
3116	END DO
3117	END IF
3118	! F. Codron
3119	ELSE
3120	! The continents have changed. The new fraction receives the mean sum of the existent fractions
3121	qsurf(i,nsrf) = qsurf(i,nsrf_comp2)pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)pctsrf_old(i,nsrf_comp3)
3122	evap(i,nsrf) = evap(i,nsrf_comp2) pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) pctsrf_old(i,nsrf_comp3)
3123	z0m(i,nsrf) = z0m(i,nsrf_comp2)pctsrf_old(i,nsrf_comp2) + z0m(i,nsrf_comp3)pctsrf_old(i,nsrf_comp3)
3124	z0h(i,nsrf) = z0h(i,nsrf_comp2)pctsrf_old(i,nsrf_comp2) + z0h(i,nsrf_comp3)pctsrf_old(i,nsrf_comp3)
3125	tsurf(i,nsrf) = tsurf(i,nsrf_comp2)pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)pctsrf_old(i,nsrf_comp3)
3126	!albedo SB >>>
3127	DO k=1,nsw
3128	alb_dir(i,k,nsrf)=alb_dir(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&
3129	alb_dir(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
3130	alb_dif(i,k,nsrf)=alb_dif(i,k,nsrf_comp2)*pctsrf_old(i,nsrf_comp2)+&
3131	alb_dif(i,k,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
3132	ENDDO
3133	!albedo SB <<<
3134	ustar(i,nsrf) = ustar(i,nsrf_comp2) pctsrf_old(i,nsrf_comp2) + ustar(i,nsrf_comp3) pctsrf_old(i,nsrf_comp3)
3135	u10m(i,nsrf) = u10m(i,nsrf_comp2) pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) pctsrf_old(i,nsrf_comp3)
3136	v10m(i,nsrf) = v10m(i,nsrf_comp2) pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) pctsrf_old(i,nsrf_comp3)
3137	if (iflag_pbl > 1) then
3138	tke(i,:,nsrf) = tke(i,:,nsrf_comp2)pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)pctsrf_old(i,nsrf_comp3)
3139	endif
3140
3141	! Security abort. This option has never been tested. To test, comment the following line.
3142	! abort_message='The fraction of the continents have changed!'
3143	! CALL abort_physic(modname,abort_message,1)
3144	nfois(nsrf) = nfois(nsrf) + 1
3145	END IF
3146	snow(i,nsrf) = 0.
3147	agesno(i,nsrf) = 0.
3148	ftsoil(i,:,nsrf) = tsurf(i,nsrf)
3149	ELSE
3150	pfois(nsrf) = pfois(nsrf)+ 1
3151	END IF
3152	END DO
3153
3154	END DO
3155
3156	END SUBROUTINE pbl_surface_newfrac
3157
3158	!
3159	!****************************************************************************************
3160	!
3161
3162	END MODULE pbl_surface_mod
3163

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format