Context Navigation

physiq_mod.F90 @ 5212

Last change on this file since 5212 was 2886, checked in by Laurent Fairhead, 7 years ago
Merged trunk changes r2865:2885 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:keywords set to `Author Date Id Revision`
File size: 157.7 KB

Line
1	!
2	! $Id: physiq_mod.F90 2886 2017-05-20 07:41:16Z evignon $
3	!
4	!#define IO_DEBUG
5	MODULE physiq_mod
6
7	IMPLICIT NONE
8
9	CONTAINS
10
11	SUBROUTINE physiq (nlon,nlev, &
12	debut,lafin,pdtphys_, &
13	paprs,pplay,pphi,pphis,presnivs, &
14	u,v,rot,t,qx, &
15	flxmass_w, &
16	d_u, d_v, d_t, d_qx, d_ps)
17
18	use assert_m, only: assert
19	USE ioipsl, only: histbeg, histvert, histdef, histend, histsync, &
20	histwrite, ju2ymds, ymds2ju, getin
21	USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg
22	USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, &
23	year_cur, mth_cur,jD_cur, jH_cur, jD_ref, day_cur, hour
24	USE write_field_phy
25	USE dimphy
26	USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac
27	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo
28	USE mod_phys_lmdz_para
29	USE iophy
30	USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
31	USE phystokenc_mod, ONLY: offline, phystokenc
32	USE time_phylmdz_mod, only: raz_date, day_step_phy, update_time,current_time
33	USE vampir
34	USE pbl_surface_mod, ONLY : pbl_surface
35	USE change_srf_frac_mod
36	USE surface_data, ONLY : type_ocean, ok_veget, ok_snow
37	USE tropopause_m, ONLY: dyn_tropopause
38	#ifdef CPP_Dust
39	USE phytracr_spl_mod, ONLY: phytracr_spl
40	#endif
41	USE phys_local_var_mod, ONLY: phys_local_var_init, phys_local_var_end, &
42	! [Variables internes non sauvegardees de la physique]
43	! Variables locales pour effectuer les appels en serie
44	t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,tr_seri, &
45	! Dynamic tendencies (diagnostics)
46	d_t_dyn,d_q_dyn,d_ql_dyn,d_qs_dyn,d_u_dyn,d_v_dyn,d_tr_dyn, &
47	d_q_dyn2d,d_ql_dyn2d,d_qs_dyn2d, &
48	! Physic tendencies
49	d_t_con,d_q_con,d_u_con,d_v_con, &
50	d_tr, & !! to be removed?? (jyg)
51	d_t_wake,d_q_wake, &
52	d_t_lwr,d_t_lw0,d_t_swr,d_t_sw0, &
53	d_t_ajsb,d_q_ajsb, &
54	d_t_ajs,d_q_ajs,d_u_ajs,d_v_ajs, &
55	d_t_ajs_w,d_q_ajs_w, &
56	d_t_ajs_x,d_q_ajs_x, &
57	!
58	d_t_eva,d_q_eva,d_ql_eva,d_qi_eva, &
59	d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc, &
60	d_t_lscst,d_q_lscst, &
61	d_t_lscth,d_q_lscth, &
62	plul_st,plul_th, &
63	!
64	d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_t_diss, &
65	d_t_vdf_w,d_q_vdf_w, &
66	d_t_vdf_x,d_q_vdf_x, &
67	d_ts, &
68	!
69	d_t_oli,d_u_oli,d_v_oli, &
70	d_t_oro,d_u_oro,d_v_oro, &
71	d_t_lif,d_u_lif,d_v_lif, &
72	d_t_ec, &
73	!
74	du_gwd_hines,dv_gwd_hines,d_t_hin, &
75	dv_gwd_rando,dv_gwd_front, &
76	east_gwstress,west_gwstress, &
77	d_q_ch4, &
78	! Special RRTM
79	ZLWFT0_i,ZSWFT0_i,ZFLDN0, &
80	ZFLUP0,ZFSDN0,ZFSUP0, &
81	!
82	topswad_aero,solswad_aero, &
83	topswai_aero,solswai_aero, &
84	topswad0_aero,solswad0_aero, &
85	!LW additional
86	toplwad_aero,sollwad_aero, &
87	toplwai_aero,sollwai_aero, &
88	toplwad0_aero,sollwad0_aero, &
89	!
90	topsw_aero,solsw_aero, &
91	topsw0_aero,solsw0_aero, &
92	topswcf_aero,solswcf_aero, &
93	tausum_aero,tau3d_aero, &
94	drytausum_aero, &
95	!
96	!variables CFMIP2/CMIP5
97	topswad_aerop, solswad_aerop, &
98	topswai_aerop, solswai_aerop, &
99	topswad0_aerop, solswad0_aerop, &
100	topsw_aerop, topsw0_aerop, &
101	solsw_aerop, solsw0_aerop, &
102	topswcf_aerop, solswcf_aerop, &
103	!LW diagnostics
104	toplwad_aerop, sollwad_aerop, &
105	toplwai_aerop, sollwai_aerop, &
106	toplwad0_aerop, sollwad0_aerop, &
107	!
108	ptstar, pt0, slp, &
109	!
110	bils, &
111	!
112	cldh, cldl,cldm, cldq, cldt, &
113	JrNt, &
114	dthmin, evap, fder, plcl, plfc, &
115	prw, prlw, prsw, &
116	s_lcl, s_pblh, s_pblt, s_therm, &
117	cdragm, cdragh, &
118	zustar, zu10m, zv10m, rh2m, qsat2m, &
119	zq2m, zt2m, weak_inversion, &
120	zt2m_min_mon, zt2m_max_mon, & ! pour calcul_divers.h
121	t2m_min_mon, t2m_max_mon, & ! pour calcul_divers.h
122	!
123	s_pblh_x, s_pblh_w, &
124	s_lcl_x, s_lcl_w, &
125	!
126	slab_wfbils, tpot, tpote, &
127	ue, uq, ve, vq, zxffonte, &
128	zxfqcalving, zxfluxlat, &
129	zxrunofflic, &
130	zxtsol, snow_lsc, zxfqfonte, zxqsurf, &
131	rain_lsc, rain_num, &
132	!
133	sens_x, sens_w, &
134	zxfluxlat_x, zxfluxlat_w, &
135	!
136	dtvdf_x, dtvdf_w, &
137	dqvdf_x, dqvdf_w, &
138	pbl_tke_input, &
139	t_therm, q_therm, u_therm, v_therm, &
140	cdragh_x, cdragh_w, &
141	cdragm_x, cdragm_w, &
142	kh, kh_x, kh_w, &
143	!
144	wake_k, &
145	ale_wake, alp_wake, &
146	wake_h, wake_omg, &
147	! tendencies of delta T and delta q:
148	d_deltat_wk, d_deltaq_wk, & ! due to wakes
149	d_deltat_wk_gw, d_deltaq_wk_gw, & ! due to wake induced gravity waves
150	d_deltat_vdf, d_deltaq_vdf, & ! due to vertical diffusion
151	d_deltat_the, d_deltaq_the, & ! due to thermals
152	d_deltat_ajs_cv, d_deltaq_ajs_cv, & ! due to dry adjustment of (w) before convection
153	! tendencies of wake fractional area and wake number per unit area:
154	d_s_wk, d_dens_wk, & ! due to wakes
155	!!! d_s_vdf, d_dens_vdf, & ! due to vertical diffusion
156	!!! d_s_the, d_dens_the, & ! due to thermals
157	!
158	ptconv, &
159	wbeff, convoccur, zmax_th, &
160	sens, flwp, fiwp, &
161	ale_bl_stat,alp_bl_conv,alp_bl_det, &
162	alp_bl_fluct_m,alp_bl_fluct_tke, &
163	alp_bl_stat, n2, s2, &
164	proba_notrig, random_notrig, &
165	!
166	dnwd, dnwd0, &
167	upwd, omega, &
168	epmax_diag, &
169	ep, &
170	cldemi, &
171	cldfra, cldtau, fiwc, &
172	fl, re, flwc, &
173	ref_liq, ref_ice, theta, &
174	ref_liq_pi, ref_ice_pi, &
175	zphi, zx_rh, &
176	pmfd, pmfu, &
177	!
178	t2m, fluxlat, &
179	fsollw, evap_pot, &
180	fsolsw, wfbils, wfbilo, &
181	wfevap, wfrain, wfsnow, &
182	pmflxr, pmflxs, prfl, &
183	psfl, fraca, Vprecip, &
184	zw2, &
185
186	fluxu, fluxv, &
187	fluxt, &
188
189	uwriteSTD, vwriteSTD, & !pour calcul_STDlev.h
190	wwriteSTD, phiwriteSTD, & !pour calcul_STDlev.h
191	qwriteSTD, twriteSTD, rhwriteSTD, & !pour calcul_STDlev.h
192
193	wdtrainA, wdtrainM, &
194	beta_prec, &
195	rneb, &
196	zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic, &
197	pr_tropopause
198	!
199	USE phys_state_var_mod ! Variables sauvegardees de la physique
200	#ifdef CPP_Dust
201	USE phys_output_write_spl_mod
202	#else
203	USE phys_output_var_mod ! Variables pour les ecritures des sorties
204	#endif
205
206	USE phys_output_write_mod
207	USE fonte_neige_mod, ONLY : fonte_neige_get_vars
208	USE phys_output_mod
209	USE phys_output_ctrlout_mod
210	use open_climoz_m, only: open_climoz ! ozone climatology from a file
211	use regr_pr_time_av_m, only: regr_pr_time_av
212	use netcdf95, only: nf95_close
213	!IM for NMC files
214	! use netcdf, only: nf90_fill_real
215	use netcdf
216	use mod_phys_lmdz_mpi_data, only: is_mpi_root
217	USE aero_mod
218	use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer
219	use conf_phys_m, only: conf_phys
220	use radlwsw_m, only: radlwsw
221	use phyaqua_mod, only: zenang_an
222	USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, &
223	start_time, pdtphys, day_ini
224	USE tracinca_mod, ONLY: config_inca
225	#ifdef CPP_XIOS
226	USE wxios, ONLY: missing_val, missing_val_omp
227	USE xios, ONLY: xios_get_field_attr, xios_field_is_active
228	#endif
229	#ifdef REPROBUS
230	USE CHEM_REP, ONLY : Init_chem_rep_xjour
231	#endif
232	USE indice_sol_mod
233	USE phytrac_mod, ONLY : phytrac
234
235	#ifdef CPP_RRTM
236	USE YOERAD, ONLY : NRADLP
237	USE YOESW, ONLY : RSUN
238	#endif
239	USE ioipsl_getin_p_mod, ONLY : getin_p
240
241	#ifndef CPP_XIOS
242	USE paramLMDZ_phy_mod
243	#endif
244
245	USE cmp_seri_mod
246	USE add_phys_tend_mod, only : add_pbl_tend, add_phys_tend, prt_enerbil, &
247	& fl_ebil, fl_cor_ebil
248
249	!IM stations CFMIP
250	USE CFMIP_point_locations
251	use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando
252	use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando
253	USE VERTICAL_LAYERS_MOD, ONLY: aps,bps
254
255
256	IMPLICIT none
257	!>======================================================================
258	!!
259	!! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
260	!!
261	!! Objet: Moniteur general de la physique du modele
262	!!AA Modifications quant aux traceurs :
263	!!AA - uniformisation des parametrisations ds phytrac
264	!!AA - stockage des moyennes des champs necessaires
265	!!AA en mode traceur off-line
266	!!======================================================================
267	!! CLEFS CPP POUR LES IO
268	!! =====================
269	#define histNMC
270	!!======================================================================
271	!! modif ( P. Le Van , 12/10/98 )
272	!!
273	!! Arguments:
274	!!
275	!! nlon----input-I-nombre de points horizontaux
276	!! nlev----input-I-nombre de couches verticales, doit etre egale a klev
277	!! debut---input-L-variable logique indiquant le premier passage
278	!! lafin---input-L-variable logique indiquant le dernier passage
279	!! jD_cur -R-jour courant a l'appel de la physique (jour julien)
280	!! jH_cur -R-heure courante a l'appel de la physique (jour julien)
281	!! pdtphys-input-R-pas d'integration pour la physique (seconde)
282	!! paprs---input-R-pression pour chaque inter-couche (en Pa)
283	!! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
284	!! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
285	!! pphis---input-R-geopotentiel du sol
286	!! presnivs-input_R_pressions approximat. des milieux couches ( en PA)
287	!! u-------input-R-vitesse dans la direction X (de O a E) en m/s
288	!! v-------input-R-vitesse Y (de S a N) en m/s
289	!! t-------input-R-temperature (K)
290	!! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
291	!! d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
292	!! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
293	!! d_ql_dyn-input-R-tendance dynamique pour "ql" (kg/kg/s)
294	!! d_qs_dyn-input-R-tendance dynamique pour "qs" (kg/kg/s)
295	!! flxmass_w -input-R- flux de masse verticale
296	!! d_u-----output-R-tendance physique de "u" (m/s/s)
297	!! d_v-----output-R-tendance physique de "v" (m/s/s)
298	!! d_t-----output-R-tendance physique de "t" (K/s)
299	!! d_qx----output-R-tendance physique de "qx" (kg/kg/s)
300	!! d_ps----output-R-tendance physique de la pression au sol
301	!!======================================================================
302	integer jjmp1
303	! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1))
304	! integer iip1
305	! parameter (iip1=iim+1)
306
307	include "regdim.h"
308	include "dimsoil.h"
309	include "clesphys.h"
310	include "thermcell.h"
311	!======================================================================
312	LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE
313	PARAMETER (ok_cvl=.TRUE.)
314	LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
315	PARAMETER (ok_gust=.FALSE.)
316	integer iflag_radia ! active ou non le rayonnement (MPL)
317	save iflag_radia
318	!$OMP THREADPRIVATE(iflag_radia)
319	!======================================================================
320	LOGICAL check ! Verifier la conservation du modele en eau
321	PARAMETER (check=.FALSE.)
322	LOGICAL ok_stratus ! Ajouter artificiellement les stratus
323	PARAMETER (ok_stratus=.FALSE.)
324	!======================================================================
325	REAL amn, amx
326	INTEGER igout
327	!======================================================================
328	! Clef controlant l'activation du cycle diurne:
329	! en attente du codage des cles par Fred
330	INTEGER iflag_cycle_diurne
331	PARAMETER (iflag_cycle_diurne=1)
332	!======================================================================
333	! Modele thermique du sol, a activer pour le cycle diurne:
334	!cc LOGICAL soil_model
335	!cc PARAMETER (soil_model=.FALSE.)
336	!======================================================================
337	! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
338	! le calcul du rayonnement est celle apres la precipitation des nuages.
339	! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
340	! la condensation et la precipitation. Cette cle augmente les impacts
341	! radiatifs des nuages.
342	!cc LOGICAL new_oliq
343	!cc PARAMETER (new_oliq=.FALSE.)
344	!======================================================================
345	! Clefs controlant deux parametrisations de l'orographie:
346	!c LOGICAL ok_orodr
347	!cc PARAMETER (ok_orodr=.FALSE.)
348	!cc LOGICAL ok_orolf
349	!cc PARAMETER (ok_orolf=.FALSE.)
350	!======================================================================
351	LOGICAL ok_journe ! sortir le fichier journalier
352	save ok_journe
353	!$OMP THREADPRIVATE(ok_journe)
354	!
355	LOGICAL ok_mensuel ! sortir le fichier mensuel
356	save ok_mensuel
357	!$OMP THREADPRIVATE(ok_mensuel)
358	!
359	LOGICAL ok_instan ! sortir le fichier instantane
360	save ok_instan
361	!$OMP THREADPRIVATE(ok_instan)
362	!
363	LOGICAL ok_LES ! sortir le fichier LES
364	save ok_LES
365	!$OMP THREADPRIVATE(ok_LES)
366	!
367	LOGICAL callstats ! sortir le fichier stats
368	save callstats
369	!$OMP THREADPRIVATE(callstats)
370	!
371	LOGICAL ok_region ! sortir le fichier regional
372	PARAMETER (ok_region=.FALSE.)
373	!======================================================================
374	real seuil_inversion
375	save seuil_inversion
376	!$OMP THREADPRIVATE(seuil_inversion)
377	integer iflag_ratqs
378	save iflag_ratqs
379	!$OMP THREADPRIVATE(iflag_ratqs)
380	real facteur
381
382	REAL wmax_th(klon)
383	REAL tau_overturning_th(klon)
384
385	integer lmax_th(klon)
386	integer limbas(klon)
387	real ratqscth(klon,klev)
388	real ratqsdiff(klon,klev)
389	real zqsatth(klon,klev)
390
391	!======================================================================
392	!
393	INTEGER ivap ! indice de traceurs pour vapeur d'eau
394	PARAMETER (ivap=1)
395	INTEGER iliq ! indice de traceurs pour eau liquide
396	PARAMETER (iliq=2)
397	!CR: on ajoute la phase glace
398	INTEGER isol ! indice de traceurs pour eau glace
399	PARAMETER (isol=3)
400	!
401	!
402	! Variables argument:
403	!
404	INTEGER nlon
405	INTEGER nlev
406	REAL,INTENT(IN) :: pdtphys_
407	! NB: pdtphys to be used in physics is in time_phylmdz_mod
408	LOGICAL debut, lafin
409	REAL paprs(klon,klev+1)
410	REAL pplay(klon,klev)
411	REAL pphi(klon,klev)
412	REAL pphis(klon)
413	REAL presnivs(klev)
414	!JLD REAL znivsig(klev)
415	!JLD real pir
416
417	REAL u(klon,klev)
418	REAL v(klon,klev)
419
420	REAL, intent(in):: rot(klon, klev)
421	! relative vorticity, in s-1, needed for frontal waves
422
423	REAL t(klon,klev),thetal(klon,klev)
424	! thetal: ligne suivante a decommenter si vous avez les fichiers
425	! MPL 20130625
426	! fth_fonctions.F90 et parkind1.F90
427	! sinon thetal=theta
428	! REAL fth_thetae,fth_thetav,fth_thetal
429	REAL qx(klon,klev,nqtot)
430	REAL flxmass_w(klon,klev)
431	REAL d_u(klon,klev)
432	REAL d_v(klon,klev)
433	REAL d_t(klon,klev)
434	REAL d_qx(klon,klev,nqtot)
435	REAL d_ps(klon)
436	! Variables pour le transport convectif
437	real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
438	real wght_cvfd(klon,klev)
439	#ifndef CPP_XIOS
440	REAL, SAVE :: missing_val
441	#endif
442	! Variables pour le lessivage convectif
443	! RomP >>>
444	real phi2(klon,klev,klev)
445	real d1a(klon,klev),dam(klon,klev)
446	real ev(klon,klev)
447	real clw(klon,klev),elij(klon,klev,klev)
448	real epmlmMm(klon,klev,klev),eplaMm(klon,klev)
449	! RomP <<<
450	!IM definition dynamique o_trac dans phys_output_open
451	! type(ctrl_out) :: o_trac(nqtot)
452
453	! variables a une pression donnee
454	!
455	include "declare_STDlev.h"
456	!
457	!
458	include "radopt.h"
459	!
460	!
461	INTEGER debug
462	INTEGER n
463	!ym INTEGER npoints
464	!ym PARAMETER(npoints=klon)
465	!
466	INTEGER nregISCtot
467	PARAMETER(nregISCtot=1)
468	!
469	! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties
470	! sur 1 region rectangulaire y compris pour 1 point
471	! imin_debut : indice minimum de i; nbpti : nombre de points en
472	! direction i (longitude)
473	! jmin_debut : indice minimum de j; nbptj : nombre de points en
474	! direction j (latitude)
475	!JLD INTEGER imin_debut, nbpti
476	!JLD INTEGER jmin_debut, nbptj
477	!IM: region='3d' <==> sorties en global
478	CHARACTER*3 region
479	PARAMETER(region='3d')
480	logical ok_hf
481	!
482	save ok_hf
483	!$OMP THREADPRIVATE(ok_hf)
484
485	INTEGER,PARAMETER :: longcles=20
486	REAL,SAVE :: clesphy0(longcles)
487	!$OMP THREADPRIVATE(clesphy0)
488	!
489	! Variables propres a la physique
490	INTEGER itap
491	SAVE itap ! compteur pour la physique
492	!$OMP THREADPRIVATE(itap)
493
494	INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys
495	!$OMP THREADPRIVATE(abortphy)
496	!
497	REAL,save :: solarlong0
498	!$OMP THREADPRIVATE(solarlong0)
499
500	!
501	! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
502	!
503	!IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
504	REAL zulow(klon),zvlow(klon)
505	!
506	INTEGER igwd,idx(klon),itest(klon)
507	!
508	! REAL,allocatable,save :: run_off_lic_0(:)
509	! !$OMP THREADPRIVATE(run_off_lic_0)
510	!ym SAVE run_off_lic_0
511	!KE43
512	! Variables liees a la convection de K. Emanuel (sb):
513	!
514	REAL bas, top ! cloud base and top levels
515	SAVE bas
516	SAVE top
517	!$OMP THREADPRIVATE(bas, top)
518	!------------------------------------------------------------------
519	! Upmost level reached by deep convection and related variable (jyg)
520	!
521	INTEGER izero
522	INTEGER k_upper_cv
523	!------------------------------------------------------------------
524	!
525	!==========================================================================
526	!CR04.12.07: on ajoute les nouvelles variables du nouveau schema
527	!de convection avec poches froides
528	! Variables li\'ees \`a la poche froide (jyg)
529
530	REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level
531	!
532	REAL wape_prescr, fip_prescr
533	INTEGER it_wape_prescr
534	SAVE wape_prescr, fip_prescr, it_wape_prescr
535	!$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr)
536	!
537	! variables supplementaires de concvl
538	REAL Tconv(klon,klev)
539	REAL sij(klon,klev,klev)
540	!! !
541	!! ! variables pour tester la conservation de l'energie dans concvl
542	!! REAL, DIMENSION(klon,klev) :: d_t_con_sat
543	!! REAL, DIMENSION(klon,klev) :: d_q_con_sat
544	!! REAL, DIMENSION(klon,klev) :: dql_sat
545
546	real, save :: alp_bl_prescr=0.
547	real, save :: ale_bl_prescr=0.
548
549	real, save :: wake_s_min_lsp=0.1
550
551	!$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr)
552	!$OMP THREADPRIVATE(wake_s_min_lsp)
553
554
555	real ok_wk_lsp(klon)
556
557	!RC
558	! Variables li\'ees \`a la poche froide (jyg et rr)
559
560	INTEGER, SAVE :: iflag_wake_tend ! wake: if =0, then wake state variables are
561	! updated within calwake
562	!$OMP THREADPRIVATE(iflag_wake_tend)
563	REAL t_w(klon,klev),q_w(klon,klev) ! temperature and moisture profiles in the wake region
564	REAL t_x(klon,klev),q_x(klon,klev) ! temperature and moisture profiles in the off-wake region
565
566	REAL wake_dth(klon,klev) ! wake : temp pot difference
567
568	REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta
569	! transported by LS omega
570	REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of
571	! large scale omega
572	REAL wake_dtKE(klon,klev) ! Wake : differential heating
573	! (wake - unpertubed) CONV
574	REAL wake_dqKE(klon,klev) ! Wake : differential moistening
575	! (wake - unpertubed) CONV
576	REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg
577	REAL wake_spread(klon,klev) ! spreading term in wake_delt
578	!
579	!pourquoi y'a pas de save??
580	!
581	!!! INTEGER, SAVE, DIMENSION(klon) :: wake_k
582	!!! !$OMP THREADPRIVATE(wake_k)
583	!
584	!jyg<
585	!cc REAL wake_pe(klon) ! Wake potential energy - WAPE
586	!>jyg
587
588	REAL wake_gfl(klon) ! Gust Front Length
589	!!! REAL wake_dens(klon) ! moved to phys_state_var_mod
590	!
591	!
592	REAL dt_dwn(klon,klev)
593	REAL dq_dwn(klon,klev)
594	REAL M_dwn(klon,klev)
595	REAL M_up(klon,klev)
596	REAL dt_a(klon,klev)
597	REAL dq_a(klon,klev)
598	REAL d_t_adjwk(klon,klev) !jyg
599	REAL d_q_adjwk(klon,klev) !jyg
600	LOGICAL,SAVE :: ok_adjwk=.FALSE.
601	!$OMP THREADPRIVATE(ok_adjwk)
602	INTEGER,SAVE :: iflag_adjwk=0 !jyg
603	!$OMP THREADPRIVATE(iflag_adjwk) !jyg
604	REAL,SAVE :: oliqmax=999.,oicemax=999.
605	!$OMP THREADPRIVATE(oliqmax,oicemax)
606	REAL, SAVE :: alp_offset
607	!$OMP THREADPRIVATE(alp_offset)
608
609	!
610	!RR:fin declarations poches froides
611	!==========================================================================
612
613	REAL ztv(klon,klev),ztva(klon,klev)
614	REAL zpspsk(klon,klev)
615	REAL ztla(klon,klev),zqla(klon,klev)
616	REAL zthl(klon,klev)
617
618	!cc nrlmd le 10/04/2012
619
620	!--------Stochastic Boundary Layer Triggering: ALE_BL--------
621	!---Propri\'et\'es du thermiques au LCL
622	real zlcl_th(klon) ! Altitude du LCL calcul\'e
623	! continument (pcon dans
624	! thermcell_main.F90)
625	real fraca0(klon) ! Fraction des thermiques au LCL
626	real w0(klon) ! Vitesse des thermiques au LCL
627	real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL
628	real tke0(klon,klev+1) ! TKE au d\'ebut du pas de temps
629	real therm_tke_max0(klon) ! TKE dans les thermiques au LCL
630	real env_tke_max0(klon) ! TKE dans l'environnement au LCL
631
632	!JLD !---D\'eclenchement stochastique
633	!JLD integer :: tau_trig(klon)
634
635	REAL,SAVE :: random_notrig_max=1.
636	!$OMP THREADPRIVATE(random_notrig_max)
637
638	!--------Statistical Boundary Layer Closure: ALP_BL--------
639	!---Profils de TKE dans et hors du thermique
640	real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques
641	real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement
642
643
644	!cc fin nrlmd le 10/04/2012
645
646	! Variables locales pour la couche limite (al1):
647	!
648	!Al1 REAL pblh(klon) ! Hauteur de couche limite
649	!Al1 SAVE pblh
650	!34EK
651	!
652	! Variables locales:
653	!
654	!AA
655	!AA Pour phytrac
656	REAL u1(klon) ! vents dans la premiere couche U
657	REAL v1(klon) ! vents dans la premiere couche V
658
659	!@$$ LOGICAL offline ! Controle du stockage ds "physique"
660	!@$$ PARAMETER (offline=.false.)
661	!@$$ INTEGER physid
662	REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
663	REAL frac_nucl(klon,klev) ! idem (nucleation)
664	! RomP >>>
665	REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt)
666	! RomP <<<
667	REAL :: calday
668
669	!IM cf FH pour Tiedtke 080604
670	REAL rain_tiedtke(klon),snow_tiedtke(klon)
671	!
672	!IM 050204 END
673	REAL devap(klon) ! evaporation et sa derivee
674	REAL dsens(klon) ! chaleur sensible et sa derivee
675
676	!
677	! Conditions aux limites
678	!
679	!
680	REAL :: day_since_equinox
681	! Date de l'equinoxe de printemps
682	INTEGER, parameter :: mth_eq=3, day_eq=21
683	REAL :: jD_eq
684
685	LOGICAL, parameter :: new_orbit = .true.
686
687	!
688	INTEGER lmt_pas
689	SAVE lmt_pas ! frequence de mise a jour
690	!$OMP THREADPRIVATE(lmt_pas)
691	real zmasse(klon, nbp_lev),exner(klon, nbp_lev)
692	! (column-density of mass of air in a cell, in kg m-2)
693	real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
694
695	!IM sorties
696	REAL un_jour
697	PARAMETER(un_jour=86400.)
698	INTEGER itapm1 !pas de temps de la physique du(es) mois precedents
699	SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours
700	!$OMP THREADPRIVATE(itapm1)
701	!======================================================================
702	!
703	! Declaration des procedures appelees
704	!
705	EXTERNAL angle ! calculer angle zenithal du soleil
706	EXTERNAL alboc ! calculer l'albedo sur ocean
707	EXTERNAL ajsec ! ajustement sec
708	EXTERNAL conlmd ! convection (schema LMD)
709	!KE43
710	EXTERNAL conema3 ! convect4.3
711	EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie)
712	!AA
713	! JBM (3/14) fisrtilp_tr not loaded
714	! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
715	! ! stockage des coefficients necessaires au
716	! ! lessivage OFF-LINE et ON-LINE
717	EXTERNAL hgardfou ! verifier les temperatures
718	EXTERNAL nuage ! calculer les proprietes radiatives
719	!C EXTERNAL o3cm ! initialiser l'ozone
720	EXTERNAL orbite ! calculer l'orbite terrestre
721	EXTERNAL phyetat0 ! lire l'etat initial de la physique
722	EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique
723	EXTERNAL suphel ! initialiser certaines constantes
724	EXTERNAL transp ! transport total de l'eau et de l'energie
725	!IM
726	EXTERNAL haut2bas !variables de haut en bas
727	EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression
728	EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression
729	! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression
730	! EXTERNAL moyglo_aire
731	! moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
732	! par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
733	!
734	!
735	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
736	! Local variables
737	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
738	!
739	REAL rhcl(klon,klev) ! humiditi relative ciel clair
740	REAL dialiq(klon,klev) ! eau liquide nuageuse
741	REAL diafra(klon,klev) ! fraction nuageuse
742	REAL cldliq(klon,klev) ! eau liquide nuageuse
743	!
744	!XXX PB
745	REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite
746	!
747	REAL zxfluxt(klon, klev)
748	REAL zxfluxq(klon, klev)
749	REAL zxfluxu(klon, klev)
750	REAL zxfluxv(klon, klev)
751
752	! Le rayonnement n'est pas calcule tous les pas, il faut donc
753	! sauvegarder les sorties du rayonnement
754	!ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
755	!ym SAVE sollwdownclr, toplwdown, toplwdownclr
756	!ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0
757	!
758	INTEGER itaprad
759	SAVE itaprad
760	!$OMP THREADPRIVATE(itaprad)
761	!
762	REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
763	REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
764	!
765	#ifdef INCA
766	REAL zxsnow_dummy(klon)
767	#endif
768	REAL zsav_tsol(klon)
769	!
770	REAL dist, rmu0(klon), fract(klon)
771	REAL zrmu0(klon), zfract(klon)
772	REAL zdtime, zdtime1, zdtime2, zlongi
773	!
774	REAL qcheck
775	REAL z_avant(klon), z_apres(klon), z_factor(klon)
776	LOGICAL zx_ajustq
777	!
778	REAL za
779	REAL zx_t, zx_qs, zdelta, zcor
780	real zqsat(klon,klev)
781	!
782	INTEGER i, k, iq, nsrf, l
783	!
784	REAL t_coup
785	PARAMETER (t_coup=234.0)
786
787	!ym A voir plus tard !!
788	!ym REAL zx_relief(iim,jjmp1)
789	!ym REAL zx_aire(iim,jjmp1)
790	!
791	! Grandeurs de sorties
792	REAL s_capCL(klon)
793	REAL s_oliqCL(klon), s_cteiCL(klon)
794	REAL s_trmb1(klon), s_trmb2(klon)
795	REAL s_trmb3(klon)
796
797	! La convection n'est pas calculee tous les pas, il faut donc
798	! sauvegarder les sorties de la convection
799	!ym SAVE
800	!ym SAVE
801	!ym SAVE
802	!
803	INTEGER itapcv, itapwk
804	SAVE itapcv, itapwk
805	!$OMP THREADPRIVATE(itapcv, itapwk)
806
807	!KE43
808	! Variables locales pour la convection de K. Emanuel (sb):
809
810	REAL tvp(klon,klev) ! virtual temp of lifted parcel
811	CHARACTER*40 capemaxcels !max(CAPE)
812
813	REAL rflag(klon) ! flag fonctionnement de convect
814	INTEGER iflagctrl(klon) ! flag fonctionnement de convect
815
816	! -- convect43:
817	INTEGER ntra ! nb traceurs pour convect4.3
818	REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
819	REAL dplcldt(klon), dplcldr(klon)
820	!? . condm_con(klon,klev),conda_con(klon,klev),
821	!? . mr_con(klon,klev),ep_con(klon,klev)
822	!? . ,sadiab(klon,klev),wadiab(klon,klev)
823	! --
824	!34EK
825	!
826	! Variables du changement
827	!
828	! con: convection
829	! lsc: condensation a grande echelle (Large-Scale-Condensation)
830	! ajs: ajustement sec
831	! eva: evaporation de l'eau liquide nuageuse
832	! vdf: couche limite (Vertical DiFfusion)
833	!
834	! tendance nulles
835	REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0
836	REAL, dimension(klon) :: dsig0, ddens0
837	INTEGER, dimension(klon) :: wkoccur1
838	! tendance buffer pour appel de add_phys_tend
839	REAL, DIMENSION(klon,klev) :: d_q_ch4_dtime
840	!
841	! Flag pour pouvoir ne pas ajouter les tendances.
842	! Par defaut, les tendances doivente etre ajoutees et
843	! flag_inhib_tend = 0
844	! flag_inhib_tend > 0 : tendances non ajoutees, avec un nombre
845	! croissant de print quand la valeur du flag augmente
846	!!! attention, ce flag doit etre change avec prudence !!!
847	INTEGER :: flag_inhib_tend = 0 ! 0 is the default value
848	!! INTEGER :: flag_inhib_tend = 2
849
850	!
851	!********************************************************
852	! declarations
853
854	!********************************************************
855	!IM 081204 END
856	!
857	REAL pen_u(klon,klev), pen_d(klon,klev)
858	REAL pde_u(klon,klev), pde_d(klon,klev)
859	INTEGER kcbot(klon), kctop(klon), kdtop(klon)
860	!
861	REAL ratqsc(klon,klev)
862	real ratqsbas,ratqshaut,tau_ratqs
863	save ratqsbas,ratqshaut,tau_ratqs
864	!$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs)
865	REAL, SAVE :: ratqsp0=50000., ratqsdp=20000.
866	!$OMP THREADPRIVATE(ratqsp0, ratqsdp)
867
868	! Parametres lies au nouveau schema de nuages (SB, PDF)
869	real fact_cldcon
870	real facttemps
871	logical ok_newmicro
872	save ok_newmicro
873	!$OMP THREADPRIVATE(ok_newmicro)
874	!real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev)
875	save fact_cldcon,facttemps
876	!$OMP THREADPRIVATE(fact_cldcon,facttemps)
877
878	integer iflag_cld_th
879	save iflag_cld_th
880	!$OMP THREADPRIVATE(iflag_cld_th)
881	!IM logical ptconv(klon,klev) !passe dans phys_local_var_mod
882	!IM cf. AM 081204 BEG
883	logical ptconvth(klon,klev)
884	!IM cf. AM 081204 END
885	!
886	! Variables liees a l'ecriture de la bande histoire physique
887	!
888	!======================================================================
889	!
890
891	!
892	!JLD integer itau_w ! pas de temps ecriture = itap + itau_phy
893	!
894	!
895	! Variables locales pour effectuer les appels en serie
896	!
897	!IM RH a 2m (la surface)
898	REAL Lheat
899
900	INTEGER length
901	PARAMETER ( length = 100 )
902	REAL tabcntr0( length )
903	!
904	!JLD INTEGER ndex2d(nbp_lon*nbp_lat)
905	!IM
906	!
907	!IM AMIP2 BEG
908	!JLD REAL moyglo, mountor
909	!IM 141004 BEG
910	REAL zustrdr(klon), zvstrdr(klon)
911	REAL zustrli(klon), zvstrli(klon)
912	REAL zustrph(klon), zvstrph(klon)
913	REAL aam, torsfc
914	!IM 141004 END
915	!IM 190504 BEG
916	! INTEGER imp1jmp1
917	! PARAMETER(imp1jmp1=(iim+1)*jjmp1)
918	!ym A voir plus tard
919	! REAL zx_tmp((nbp_lon+1)*nbp_lat)
920	! REAL airedyn(nbp_lon+1,nbp_lat)
921	!IM 190504 END
922	!JLD LOGICAL ok_msk
923	!JLD REAL msk(klon)
924	!ym A voir plus tard
925	!ym REAL zm_wo(jjmp1, klev)
926	!IM AMIP2 END
927	!
928	REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique
929	REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D
930	!JLD REAL zx_tmp_2d(nbp_lon,nbp_lat)
931	!JLD REAL zx_lon(nbp_lon,nbp_lat)
932	!JLD REAL zx_lat(nbp_lon,nbp_lat)
933	!
934	INTEGER nid_ctesGCM
935	SAVE nid_ctesGCM
936	!$OMP THREADPRIVATE(nid_ctesGCM)
937	!
938	!IM 280405 BEG
939	! INTEGER nid_bilKPins, nid_bilKPave
940	! SAVE nid_bilKPins, nid_bilKPave
941	! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
942	!
943	REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
944	REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
945	REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
946	REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
947	!
948	!JLD REAL zjulian
949	!JLD SAVE zjulian
950	!JLD!$OMP THREADPRIVATE(zjulian)
951
952	!JLD INTEGER nhori, nvert
953	!JLD REAL zsto
954	!JLD REAL zstophy, zout
955
956	character*20 modname
957	character*80 abort_message
958	logical, save :: ok_sync, ok_sync_omp
959	!$OMP THREADPRIVATE(ok_sync)
960	real date0
961
962	! essai writephys
963	integer fid_day, fid_mth, fid_ins
964	parameter (fid_ins = 1, fid_day = 2, fid_mth = 3)
965	integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
966	parameter (prof2d_on = 1, prof3d_on = 2, &
967	prof2d_av = 3, prof3d_av = 4)
968	REAL ztsol(klon)
969	REAL q2m(klon,nbsrf) ! humidite a 2m
970
971	!IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels
972	CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max
973	CHARACTER*40 tinst, tave
974	REAL cldtaupi(klon,klev) ! Cloud optical thickness for
975	! pre-industrial (pi) aerosols
976
977	INTEGER :: naero
978	! Aerosol optical properties
979	CHARACTER*4, DIMENSION(naero_grp) :: rfname
980	REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass
981	! concentration
982	! for all soluble
983	! aerosols[ug/m3]
984	REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi
985	! - " - (pre-industrial value)
986
987	! Parameters
988	LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not
989	LOGICAL ok_alw ! Apply aerosol LW effect or not
990	LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013)
991	REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995)
992	SAVE ok_ade, ok_aie, ok_alw, ok_cdnc, bl95_b0, bl95_b1
993	!$OMP THREADPRIVATE(ok_ade, ok_aie, ok_alw, ok_cdnc, bl95_b0, bl95_b1)
994	LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA
995	! false : lecture des aerosol dans un fichier
996	!$OMP THREADPRIVATE(aerosol_couple)
997	INTEGER, SAVE :: flag_aerosol
998	!$OMP THREADPRIVATE(flag_aerosol)
999	LOGICAL, SAVE :: flag_bc_internal_mixture
1000	!$OMP THREADPRIVATE(flag_bc_internal_mixture)
1001	LOGICAL, SAVE :: new_aod
1002	!$OMP THREADPRIVATE(new_aod)
1003	!
1004	!--STRAT AEROSOL
1005	INTEGER, SAVE :: flag_aerosol_strat
1006	!$OMP THREADPRIVATE(flag_aerosol_strat)
1007	!c-fin STRAT AEROSOL
1008	!
1009	! Declaration des constantes et des fonctions thermodynamiques
1010	!
1011	LOGICAL,SAVE :: first=.true.
1012	!$OMP THREADPRIVATE(first)
1013
1014	! VARIABLES RELATED TO OZONE CLIMATOLOGIES ; all are OpenMP shared
1015	! Note that pressure vectors are in Pa and in stricly ascending order
1016	INTEGER,SAVE :: read_climoz ! Read ozone climatology
1017	! (let it keep the default OpenMP shared attribute)
1018	! Allowed values are 0, 1 and 2
1019	! 0: do not read an ozone climatology
1020	! 1: read a single ozone climatology that will be used day and night
1021	! 2: read two ozone climatologies, the average day and night
1022	! climatology and the daylight climatology
1023	INTEGER,SAVE :: ncid_climoz ! NetCDF file identifier
1024	REAL, POINTER, SAVE :: press_cen_climoz(:) ! Pressure levels
1025	REAL, POINTER, SAVE :: press_edg_climoz(:) ! Edges of pressure intervals
1026	REAL, POINTER, SAVE :: time_climoz(:) ! Time vector
1027	CHARACTER(LEN=13), PARAMETER :: vars_climoz(2) &
1028	= ["tro3 ","tro3_daylight"]
1029	! vars_climoz(1:read_climoz): variables names in climoz file.
1030	! vars_climoz(1:read_climoz-2) if read_climoz>2 (temporary)
1031	REAL :: ro3i ! 0<=ro3i<=360 ; required time index in NetCDF file for
1032	! the ozone fields, old method.
1033
1034	include "YOMCST.h"
1035	include "YOETHF.h"
1036	include "FCTTRE.h"
1037	!IM 100106 BEG : pouvoir sortir les ctes de la physique
1038	include "conema3.h"
1039	include "fisrtilp.h"
1040	include "nuage.h"
1041	include "compbl.h"
1042	!IM 100106 END : pouvoir sortir les ctes de la physique
1043	!
1044	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1045	! Declarations pour Simulateur COSP
1046	!============================================================
1047	#ifdef CPP_COSP
1048	real :: mr_ozone(klon,klev)
1049	#endif
1050	!IM stations CFMIP
1051	INTEGER, SAVE :: nCFMIP
1052	!$OMP THREADPRIVATE(nCFMIP)
1053	INTEGER, PARAMETER :: npCFMIP=120
1054	INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:)
1055	REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:)
1056	!$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP)
1057	INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:)
1058	REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:)
1059	!$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM)
1060	INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:)
1061	!$OMP THREADPRIVATE(iGCM, jGCM)
1062	logical, dimension(nfiles) :: phys_out_filestations
1063	logical, parameter :: lNMC=.FALSE.
1064
1065	!IM betaCRF
1066	REAL, SAVE :: pfree, beta_pbl, beta_free
1067	!$OMP THREADPRIVATE(pfree, beta_pbl, beta_free)
1068	REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta
1069	!$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta)
1070	LOGICAL, SAVE :: mskocean_beta
1071	!$OMP THREADPRIVATE(mskocean_beta)
1072	REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et
1073	! cldemirad pour evaluer les
1074	! retros liees aux CRF
1075	REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique
1076	! pour radlwsw pour
1077	! tester "CRF off"
1078	REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique
1079	! pour radlwsw pour
1080	! tester "CRF off"
1081	REAL, dimension(klon, klev) :: cldemirad ! emissivite pour
1082	! radlwsw pour tester
1083	! "CRF off"
1084	REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse
1085
1086	INTEGER :: nbtr_tmp ! Number of tracer inside concvl
1087	REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac
1088	REAL, dimension(klon,klev) :: ch_in ! Condensed humidity entering in phytrac (eau liquide)
1089	integer iostat
1090
1091	REAL zzz
1092	!albedo SB >>>
1093	real,dimension(6),save :: SFRWL
1094	!albedo SB <<<
1095
1096	!--OB variables for mass fixer (hard coded for now)
1097	logical, parameter :: mass_fixer=.false.
1098	real qql1(klon),qql2(klon),corrqql
1099
1100	! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter"
1101	jjmp1=nbp_lat
1102
1103	!======================================================================
1104	! Gestion calendrier : mise a jour du module phys_cal_mod
1105	!
1106	pdtphys=pdtphys_
1107	CALL update_time(pdtphys)
1108
1109	!======================================================================
1110	! Ecriture eventuelle d'un profil verticale en entree de la physique.
1111	! Utilise notamment en 1D mais peut etre active egalement en 3D
1112	! en imposant la valeur de igout.
1113	!======================================================================d
1114	IF (prt_level.ge.1) THEN
1115	igout=klon/2+1/klon
1116	write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
1117	write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), &
1118	longitude_deg(igout)
1119	write(lunout,*) &
1120	'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys'
1121	write(lunout,*) &
1122	nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys
1123
1124	write(lunout,*) 'paprs, play, phi, u, v, t'
1125	DO k=1,klev
1126	write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), &
1127	u(igout,k),v(igout,k),t(igout,k)
1128	ENDDO
1129	write(lunout,*) 'ovap (g/kg), oliq (g/kg)'
1130	DO k=1,klev
1131	write(lunout,) qx(igout,k,1)1000,qx(igout,k,2)*1000.
1132	ENDDO
1133	ENDIF
1134
1135	! Quick check on pressure levels:
1136	call assert(paprs(:, nbp_lev + 1) < paprs(:, nbp_lev), &
1137	"physiq_mod paprs bad order")
1138
1139	IF (first) THEN
1140	!CR:nvelles variables convection/poches froides
1141
1142	print*, '================================================='
1143	print*, 'Allocation des variables locales et sauvegardees'
1144	CALL phys_local_var_init
1145	!
1146	pasphys=pdtphys
1147	! appel a la lecture du run.def physique
1148	CALL conf_phys(ok_journe, ok_mensuel, &
1149	ok_instan, ok_hf, &
1150	ok_LES, &
1151	callstats, &
1152	solarlong0,seuil_inversion, &
1153	fact_cldcon, facttemps,ok_newmicro,iflag_radia, &
1154	iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
1155	ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple, &
1156	flag_aerosol, flag_aerosol_strat, new_aod, &
1157	flag_bc_internal_mixture, bl95_b0, bl95_b1, &
1158	! nv flags pour la convection et les
1159	! poches froides
1160	read_climoz, &
1161	alp_offset)
1162	CALL phys_state_var_init(read_climoz)
1163	CALL phys_output_var_init
1164	print*, '================================================='
1165	!
1166	!CR: check sur le nb de traceurs de l eau
1167	IF ((iflag_ice_thermo.gt.0).and.(nqo==2)) THEN
1168	WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', &
1169	'(H2Ov, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.'
1170	STOP
1171	ENDIF
1172
1173	dnwd0=0.0
1174	ftd=0.0
1175	fqd=0.0
1176	cin=0.
1177	!ym Attention pbase pas initialise dans concvl !!!!
1178	pbase=0
1179	!IM 180608
1180
1181	itau_con=0
1182	first=.false.
1183
1184	ENDIF ! first
1185
1186	!ym => necessaire pour iflag_con != 2
1187	pmfd(:,:) = 0.
1188	pen_u(:,:) = 0.
1189	pen_d(:,:) = 0.
1190	pde_d(:,:) = 0.
1191	pde_u(:,:) = 0.
1192	aam=0.
1193	d_t_adjwk(:,:)=0
1194	d_q_adjwk(:,:)=0
1195
1196	alp_bl_conv(:)=0.
1197
1198	torsfc=0.
1199	forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg
1200
1201	modname = 'physiq'
1202
1203	IF (debut) THEN
1204	CALL suphel ! initialiser constantes et parametres phys.
1205	CALL getin_p('random_notrig_max',random_notrig_max)
1206	CALL getin_p('ok_adjwk',ok_adjwk)
1207	IF (ok_adjwk) iflag_adjwk=2 ! for compatibility with older versions
1208	! iflag_adjwk: ! 0 = Default: no convective adjustment of w-region
1209	! 1 => convective adjustment but state variables are unchanged
1210	! 2 => convective adjustment and state variables are changed
1211	CALL getin_p('iflag_adjwk',iflag_adjwk)
1212	CALL getin_p('oliqmax',oliqmax)
1213	CALL getin_p('oicemax',oicemax)
1214	CALL getin_p('ratqsp0',ratqsp0)
1215	CALL getin_p('ratqsdp',ratqsdp)
1216	iflag_wake_tend = 0
1217	CALL getin_p('iflag_wake_tend',iflag_wake_tend)
1218	ok_bad_ecmwf_thermo=.TRUE. ! By default thermodynamical constants are set
1219	! in rrtm/suphec.F90 (and rvtmp2 is set to 0).
1220	CALL getin_p('ok_bad_ecmwf_thermo',ok_bad_ecmwf_thermo)
1221	fl_ebil = 0 ! by default, conservation diagnostics are desactivated
1222	CALL getin_p('fl_ebil',fl_ebil)
1223	fl_cor_ebil = 0 ! by default, no correction to ensure energy conservation
1224	CALL getin_p('fl_cor_ebil',fl_cor_ebil)
1225	ENDIF
1226
1227	IF (prt_level.ge.1) print *,'CONVERGENCE PHYSIQUE THERM 1 '
1228
1229
1230	!======================================================================
1231	! Gestion calendrier : mise a jour du module phys_cal_mod
1232	!
1233	! CALL phys_cal_update(jD_cur,jH_cur)
1234
1235	!
1236	! Si c'est le debut, il faut initialiser plusieurs choses
1237	! ********
1238	!
1239	IF (debut) THEN
1240	!rv CRinitialisation de wght_th et lalim_conv pour la
1241	!definition de la couche alimentation de la convection a partir
1242	!des caracteristiques du thermique
1243	wght_th(:,:)=1.
1244	lalim_conv(:)=1
1245	!RC
1246	ustar(:,:)=0.
1247	! u10m(:,:)=0.
1248	! v10m(:,:)=0.
1249	rain_con(:)=0.
1250	snow_con(:)=0.
1251	topswai(:)=0.
1252	topswad(:)=0.
1253	solswai(:)=0.
1254	solswad(:)=0.
1255
1256	wmax_th(:)=0.
1257	tau_overturning_th(:)=0.
1258
1259	IF (type_trac == 'inca') THEN
1260	! jg : initialisation jusqu'au ces variables sont dans restart
1261	ccm(:,:,:) = 0.
1262	tau_aero(:,:,:,:) = 0.
1263	piz_aero(:,:,:,:) = 0.
1264	cg_aero(:,:,:,:) = 0.
1265
1266	config_inca='none' ! default
1267	CALL getin_p('config_inca',config_inca)
1268
1269	ELSE
1270	config_inca='none' ! default
1271	ENDIF
1272
1273	IF (aerosol_couple .AND. (config_inca /= "aero" &
1274	.AND. config_inca /= "aeNP ")) THEN
1275	abort_message &
1276	= 'if aerosol_couple is activated, config_inca need to be ' &
1277	// 'aero or aeNP'
1278	CALL abort_physic (modname,abort_message,1)
1279	ENDIF
1280
1281
1282
1283	rnebcon0(:,:) = 0.0
1284	clwcon0(:,:) = 0.0
1285	rnebcon(:,:) = 0.0
1286	clwcon(:,:) = 0.0
1287
1288	!
1289	print*,'iflag_coupl,iflag_clos,iflag_wake', &
1290	iflag_coupl,iflag_clos,iflag_wake
1291	print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne
1292	!
1293	IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN
1294	abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1'
1295	CALL abort_physic (modname,abort_message,1)
1296	ENDIF
1297	!
1298	!
1299	! Initialiser les compteurs:
1300	!
1301	itap = 0
1302	itaprad = 0
1303	itapcv = 0
1304	itapwk = 0
1305
1306	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1307	!! Un petit travail \`a faire ici.
1308	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1309
1310	IF (iflag_pbl>1) THEN
1311	PRINT*, "Using method MELLOR&YAMADA"
1312	ENDIF
1313
1314	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1315	! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans
1316	! phylmd plutot que dyn3d
1317	! Attention : la version precedente n'etait pas tres propre.
1318	! Il se peut qu'il faille prendre une valeur differente de nbapp_rad
1319	! pour obtenir le meme resultat.
1320	!jyg for fh<
1321	!! dtime=pdtphys
1322	dtime=NINT(pdtphys)
1323	WRITE(lunout,*) 'Pas de temps dtime pdtphys ',dtime,pdtphys
1324	IF (abs(dtime-pdtphys)>1.e-10) THEN
1325	abort_message='pas de temps doit etre entier en seconde pour orchidee et XIOS'
1326	CALL abort_physic(modname,abort_message,1)
1327	ENDIF
1328	!>jyg
1329	IF (MOD(NINT(86400./dtime),nbapp_rad).EQ.0) THEN
1330	radpas = NINT( 86400./dtime)/nbapp_rad
1331	ELSE
1332	WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
1333	'multiple de nbapp_rad'
1334	WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test ', &
1335	'mais 1+1<>2'
1336	abort_message='nbre de pas de temps physique n est pas multiple ' &
1337	// 'de nbapp_rad'
1338	CALL abort_physic(modname,abort_message,1)
1339	ENDIF
1340	IF (nbapp_cv .EQ. 0) nbapp_cv=86400./dtime
1341	IF (nbapp_wk .EQ. 0) nbapp_wk=86400./dtime
1342	print *,'physiq, nbapp_cv, nbapp_wk ',nbapp_cv,nbapp_wk
1343	IF (MOD(NINT(86400./dtime),nbapp_cv).EQ.0) THEN
1344	cvpas = NINT( 86400./dtime)/nbapp_cv
1345	print *,'physiq, cvpas ',cvpas
1346	ELSE
1347	WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
1348	'multiple de nbapp_cv'
1349	WRITE(lunout,*) 'changer nbapp_cv ou alors commenter ce test ', &
1350	'mais 1+1<>2'
1351	abort_message='nbre de pas de temps physique n est pas multiple ' &
1352	// 'de nbapp_cv'
1353	call abort_physic(modname,abort_message,1)
1354	ENDIF
1355	IF (MOD(NINT(86400./dtime),nbapp_wk).EQ.0) THEN
1356	wkpas = NINT( 86400./dtime)/nbapp_wk
1357	print *,'physiq, wkpas ',wkpas
1358	ELSE
1359	WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
1360	'multiple de nbapp_wk'
1361	WRITE(lunout,*) 'changer nbapp_wk ou alors commenter ce test ', &
1362	'mais 1+1<>2'
1363	abort_message='nbre de pas de temps physique n est pas multiple ' &
1364	// 'de nbapp_wk'
1365	call abort_physic(modname,abort_message,1)
1366	ENDIF
1367	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1368
1369	CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0)
1370	!jyg<
1371	IF (klon_glo==1) THEN
1372	pbl_tke(:,:,is_ave) = 0.
1373	DO nsrf=1,nbsrf
1374	DO k = 1,klev+1
1375	pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) &
1376	+pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
1377	ENDDO
1378	ENDDO
1379	!>jyg
1380	ENDIF
1381	!IM begin
1382	print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) &
1383	,ratqs(1,1)
1384	!IM end
1385
1386
1387	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1388	!
1389	! on remet le calendrier a zero
1390	!
1391	IF (raz_date .eq. 1) THEN
1392	itau_phy = 0
1393	ENDIF
1394
1395	CALL printflag( tabcntr0,radpas,ok_journe, &
1396	ok_instan, ok_region )
1397	!
1398	IF (ABS(dtime-pdtphys).GT.0.001) THEN
1399	WRITE(lunout,*) 'Pas physique n est pas correct',dtime, &
1400	pdtphys
1401	abort_message='Pas physique n est pas correct '
1402	! call abort_physic(modname,abort_message,1)
1403	dtime=pdtphys
1404	ENDIF
1405	IF (nlon .NE. klon) THEN
1406	WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, &
1407	klon
1408	abort_message='nlon et klon ne sont pas coherents'
1409	CALL abort_physic(modname,abort_message,1)
1410	ENDIF
1411	IF (nlev .NE. klev) THEN
1412	WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, &
1413	klev
1414	abort_message='nlev et klev ne sont pas coherents'
1415	CALL abort_physic(modname,abort_message,1)
1416	ENDIF
1417	!
1418	IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN
1419	WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
1420	WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
1421	abort_message='Nbre d appels au rayonnement insuffisant'
1422	CALL abort_physic(modname,abort_message,1)
1423	ENDIF
1424	WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
1425	WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", &
1426	ok_cvl
1427	!
1428	!KE43
1429	! Initialisation pour la convection de K.E. (sb):
1430	IF (iflag_con.GE.3) THEN
1431
1432	WRITE(lunout,)"** Convection de Kerry Emanuel 4.3 "
1433	WRITE(lunout,*) &
1434	"On va utiliser le melange convectif des traceurs qui"
1435	WRITE(lunout,*)"est calcule dans convect4.3"
1436	WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
1437
1438	DO i = 1, klon
1439	ema_cbmf(i) = 0.
1440	ema_pcb(i) = 0.
1441	ema_pct(i) = 0.
1442	! ema_workcbmf(i) = 0.
1443	ENDDO
1444	!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
1445	DO i = 1, klon
1446	ibas_con(i) = 1
1447	itop_con(i) = 1
1448	ENDDO
1449	!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
1450	!================================================================
1451	!CR:04.12.07: initialisations poches froides
1452	! Controle de ALE et ALP pour la fermeture convective (jyg)
1453	IF (iflag_wake>=1) THEN
1454	CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr &
1455	,alp_bl_prescr, ale_bl_prescr)
1456	! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU)
1457	! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th
1458	!
1459	! Initialize tendencies of wake state variables (for some flag values
1460	! they are not computed).
1461	d_deltat_wk(:,:) = 0.
1462	d_deltaq_wk(:,:) = 0.
1463	d_deltat_wk_gw(:,:) = 0.
1464	d_deltaq_wk_gw(:,:) = 0.
1465	d_deltat_vdf(:,:) = 0.
1466	d_deltaq_vdf(:,:) = 0.
1467	d_deltat_the(:,:) = 0.
1468	d_deltaq_the(:,:) = 0.
1469	d_deltat_ajs_cv(:,:) = 0.
1470	d_deltaq_ajs_cv(:,:) = 0.
1471	d_s_wk(:) = 0.
1472	d_dens_wk(:) = 0.
1473	ENDIF
1474
1475	! do i = 1,klon
1476	! Ale_bl(i)=0.
1477	! Alp_bl(i)=0.
1478	! enddo
1479
1480	!===================================================================
1481	!IM stations CFMIP
1482	nCFMIP=npCFMIP
1483	OPEN(98,file='npCFMIP_param.data',status='old', &
1484	form='formatted',iostat=iostat)
1485	IF (iostat == 0) THEN
1486	READ(98,*,end=998) nCFMIP
1487	998 CONTINUE
1488	CLOSE(98)
1489	CONTINUE
1490	IF(nCFMIP.GT.npCFMIP) THEN
1491	print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler'
1492	CALL abort_physic("physiq", "", 1)
1493	ELSE
1494	print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP
1495	ENDIF
1496
1497	!
1498	ALLOCATE(tabCFMIP(nCFMIP))
1499	ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP))
1500	ALLOCATE(tabijGCM(nCFMIP))
1501	ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP))
1502	ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP))
1503	!
1504	! lecture des nCFMIP stations CFMIP, de leur numero
1505	! et des coordonnees geographiques lonCFMIP, latCFMIP
1506	!
1507	CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, &
1508	lonCFMIP, latCFMIP)
1509	!
1510	! identification des
1511	! 1) coordonnees lonGCM, latGCM des points CFMIP dans la
1512	! grille de LMDZ
1513	! 2) indices points tabijGCM de la grille physique 1d sur
1514	! klon points
1515	! 3) indices iGCM, jGCM de la grille physique 2d
1516	!
1517	CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, &
1518	tabijGCM, lonGCM, latGCM, iGCM, jGCM)
1519	!
1520	ELSE
1521	ALLOCATE(tabijGCM(0))
1522	ALLOCATE(lonGCM(0), latGCM(0))
1523	ALLOCATE(iGCM(0), jGCM(0))
1524	ENDIF
1525	ELSE
1526	ALLOCATE(tabijGCM(0))
1527	ALLOCATE(lonGCM(0), latGCM(0))
1528	ALLOCATE(iGCM(0), jGCM(0))
1529	ENDIF
1530
1531	DO i=1,klon
1532	rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
1533	ENDDO
1534
1535	!34EK
1536	IF (ok_orodr) THEN
1537
1538	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1539	! FH sans doute a enlever de finitivement ou, si on le
1540	! garde, l'activer justement quand ok_orodr = false.
1541	! ce rugoro est utilise par la couche limite et fait double emploi
1542	! avec les param\'etrisations sp\'ecifiques de Francois Lott.
1543	! DO i=1,klon
1544	! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
1545	! ENDDO
1546	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1547	IF (ok_strato) THEN
1548	CALL SUGWD_strato(klon,klev,paprs,pplay)
1549	ELSE
1550	CALL SUGWD(klon,klev,paprs,pplay)
1551	ENDIF
1552
1553	DO i=1,klon
1554	zuthe(i)=0.
1555	zvthe(i)=0.
1556	IF (zstd(i).gt.10.) THEN
1557	zuthe(i)=(1.-zgam(i))*cos(zthe(i))
1558	zvthe(i)=(1.-zgam(i))*sin(zthe(i))
1559	ENDIF
1560	ENDDO
1561	ENDIF
1562	!
1563	!
1564	lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours
1565	WRITE(lunout,*)'La frequence de lecture surface est de ', &
1566	lmt_pas
1567	!
1568	capemaxcels = 't_max(X)'
1569	t2mincels = 't_min(X)'
1570	t2maxcels = 't_max(X)'
1571	tinst = 'inst(X)'
1572	tave = 'ave(X)'
1573	!IM cf. AM 081204 BEG
1574	write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
1575	!IM cf. AM 081204 END
1576	!
1577	!=============================================================
1578	! Initialisation des sorties
1579	!=============================================================
1580
1581	#ifdef CPP_XIOS
1582	!--setting up swaero_diag to TRUE in XIOS case
1583	IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. &
1584	xios_field_is_active("solswad").OR.xios_field_is_active("solswad0").OR. &
1585	xios_field_is_active("topswai").OR.xios_field_is_active("solswai").OR. &
1586	(iflag_rrtm==1.AND.(xios_field_is_active("toplwad").OR.xios_field_is_active("toplwad0").OR. &
1587	xios_field_is_active("sollwad").OR.xios_field_is_active("sollwad0")))) &
1588	!!!--for now these fields are not in the XML files so they are omitted
1589	!!! xios_field_is_active("toplwai").OR.xios_field_is_active("sollwai") !))) &
1590	swaero_diag=.TRUE.
1591
1592	!--setting up dryaod_diag to TRUE in XIOS case
1593	DO naero = 1, naero_tot-1
1594	IF (xios_field_is_active("dryod550_"//name_aero_tau(naero))) dryaod_diag=.TRUE.
1595	ENDDO
1596	#endif
1597
1598	#ifdef CPP_IOIPSL
1599
1600	!$OMP MASTER
1601	! FH : if ok_sync=.true. , the time axis is written at each time step
1602	! in the output files. Only at the end in the opposite case
1603	ok_sync_omp=.false.
1604	CALL getin('ok_sync',ok_sync_omp)
1605	CALL phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, &
1606	iGCM,jGCM,lonGCM,latGCM, &
1607	jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, &
1608	type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, &
1609	ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, &
1610	read_climoz, phys_out_filestations, &
1611	new_aod, aerosol_couple, &
1612	flag_aerosol_strat, pdtphys, paprs, pphis, &
1613	pplay, lmax_th, ptconv, ptconvth, ivap, &
1614	d_u, d_t, qx, d_qx, zmasse, ok_sync_omp)
1615	!$OMP END MASTER
1616	!$OMP BARRIER
1617	ok_sync=ok_sync_omp
1618
1619	freq_outNMC(1) = ecrit_files(7)
1620	freq_outNMC(2) = ecrit_files(8)
1621	freq_outNMC(3) = ecrit_files(9)
1622	WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1)
1623	WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2)
1624	WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3)
1625
1626	#ifndef CPP_XIOS
1627	CALL ini_paramLMDZ_phy(dtime,nid_ctesGCM)
1628	#endif
1629
1630	#endif
1631	ecrit_reg = ecrit_reg * un_jour
1632	ecrit_tra = ecrit_tra * un_jour
1633
1634	!XXXPB Positionner date0 pour initialisation de ORCHIDEE
1635	date0 = jD_ref
1636	WRITE(,) 'physiq date0 : ',date0
1637	!
1638	!
1639	!
1640	! Prescrire l'ozone dans l'atmosphere
1641	!
1642	!
1643	!c DO i = 1, klon
1644	!c DO k = 1, klev
1645	!c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
1646	!c ENDDO
1647	!c ENDDO
1648	!
1649	IF (type_trac == 'inca') THEN
1650	#ifdef INCA
1651	CALL VTe(VTphysiq)
1652	CALL VTb(VTinca)
1653	calday = REAL(days_elapsed) + jH_cur
1654	WRITE(lunout,*) 'initial time chemini', days_elapsed, calday
1655
1656	CALL chemini( &
1657	rg, &
1658	ra, &
1659	cell_area, &
1660	latitude_deg, &
1661	longitude_deg, &
1662	presnivs, &
1663	calday, &
1664	klon, &
1665	nqtot, &
1666	nqo, &
1667	pdtphys, &
1668	annee_ref, &
1669	day_ref, &
1670	day_ini, &
1671	start_time, &
1672	itau_phy, &
1673	date0, &
1674	io_lon, &
1675	io_lat)
1676
1677	CALL VTe(VTinca)
1678	CALL VTb(VTphysiq)
1679	#endif
1680	ENDIF
1681	!
1682	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1683	! Nouvelle initialisation pour le rayonnement RRTM
1684	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1685
1686	CALL iniradia(klon,klev,paprs(1,1:klev+1))
1687
1688	!$omp single
1689	IF (read_climoz >= 1) CALL open_climoz(ncid_climoz, press_cen_climoz, &
1690	press_edg_climoz, time_climoz, ok_daily_climoz, adjust_tropopause)
1691	!$omp end single
1692	!
1693	!IM betaCRF
1694	pfree=70000. !Pa
1695	beta_pbl=1.
1696	beta_free=1.
1697	lon1_beta=-180.
1698	lon2_beta=+180.
1699	lat1_beta=90.
1700	lat2_beta=-90.
1701	mskocean_beta=.FALSE.
1702
1703	!albedo SB >>>
1704	select case(nsw)
1705	case(2)
1706	SFRWL(1)=0.45538747
1707	SFRWL(2)=0.54461211
1708	case(4)
1709	SFRWL(1)=0.45538747
1710	SFRWL(2)=0.32870591
1711	SFRWL(3)=0.18568763
1712	SFRWL(4)=3.02191470E-02
1713	case(6)
1714	SFRWL(1)=1.28432794E-03
1715	SFRWL(2)=0.12304168
1716	SFRWL(3)=0.33106142
1717	SFRWL(4)=0.32870591
1718	SFRWL(5)=0.18568763
1719	SFRWL(6)=3.02191470E-02
1720	end select
1721
1722
1723	!albedo SB <<<
1724
1725	OPEN(99,file='beta_crf.data',status='old', &
1726	form='formatted',err=9999)
1727	READ(99,*,end=9998) pfree
1728	READ(99,*,end=9998) beta_pbl
1729	READ(99,*,end=9998) beta_free
1730	READ(99,*,end=9998) lon1_beta
1731	READ(99,*,end=9998) lon2_beta
1732	READ(99,*,end=9998) lat1_beta
1733	READ(99,*,end=9998) lat2_beta
1734	READ(99,*,end=9998) mskocean_beta
1735	9998 Continue
1736	CLOSE(99)
1737	9999 Continue
1738	WRITE(,)'pfree=',pfree
1739	WRITE(,)'beta_pbl=',beta_pbl
1740	WRITE(,)'beta_free=',beta_free
1741	WRITE(,)'lon1_beta=',lon1_beta
1742	WRITE(,)'lon2_beta=',lon2_beta
1743	WRITE(,)'lat1_beta=',lat1_beta
1744	WRITE(,)'lat2_beta=',lat2_beta
1745	WRITE(,)'mskocean_beta=',mskocean_beta
1746	ENDIF
1747	!
1748	! ************** Fin de IF ( debut ) *************
1749	!
1750	!
1751	! Incrementer le compteur de la physique
1752	!
1753	itap = itap + 1
1754	IF (is_master .OR. prt_level > 9) THEN
1755	IF (prt_level > 5 .or. MOD(itap,5) == 0) THEN
1756	WRITE(LUNOUT,*)'Entering physics elapsed seconds since start ', current_time
1757	WRITE(LUNOUT,100)year_cur,mth_cur,day_cur,hour/3600.
1758	100 FORMAT('Date = ',i4.4,' / ',i2.2, ' / ',i2.2,' : ',f20.17)
1759	ENDIF
1760	ENDIF
1761	!
1762	!
1763	! Update fraction of the sub-surfaces (pctsrf) and
1764	! initialize, where a new fraction has appeared, all variables depending
1765	! on the surface fraction.
1766	!
1767	CALL change_srf_frac(itap, dtime, days_elapsed+1, &
1768	pctsrf, fevap, z0m, z0h, agesno, &
1769	falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke)
1770
1771	! Update time and other variables in Reprobus
1772	IF (type_trac == 'repr') THEN
1773	#ifdef REPROBUS
1774	CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref)
1775	print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref
1776	CALL Rtime(debut)
1777	#endif
1778	ENDIF
1779
1780
1781	! Tendances bidons pour les processus qui n'affectent pas certaines
1782	! variables.
1783	du0(:,:)=0.
1784	dv0(:,:)=0.
1785	dt0 = 0.
1786	dq0(:,:)=0.
1787	dql0(:,:)=0.
1788	dqi0(:,:)=0.
1789	dsig0(:) = 0.
1790	ddens0(:) = 0.
1791	wkoccur1(:)=1
1792	!
1793	! Mettre a zero des variables de sortie (pour securite)
1794	!
1795	DO i = 1, klon
1796	d_ps(i) = 0.0
1797	ENDDO
1798	DO k = 1, klev
1799	DO i = 1, klon
1800	d_t(i,k) = 0.0
1801	d_u(i,k) = 0.0
1802	d_v(i,k) = 0.0
1803	ENDDO
1804	ENDDO
1805	DO iq = 1, nqtot
1806	DO k = 1, klev
1807	DO i = 1, klon
1808	d_qx(i,k,iq) = 0.0
1809	ENDDO
1810	ENDDO
1811	ENDDO
1812	da(:,:)=0.
1813	mp(:,:)=0.
1814	phi(:,:,:)=0.
1815	! RomP >>>
1816	phi2(:,:,:)=0.
1817	beta_prec_fisrt(:,:)=0.
1818	beta_prec(:,:)=0.
1819	epmlmMm(:,:,:)=0.
1820	eplaMm(:,:)=0.
1821	d1a(:,:)=0.
1822	dam(:,:)=0.
1823	pmflxr=0.
1824	pmflxs=0.
1825	! RomP <<<
1826
1827	!
1828	! Ne pas affecter les valeurs entrees de u, v, h, et q
1829	!
1830	DO k = 1, klev
1831	DO i = 1, klon
1832	t_seri(i,k) = t(i,k)
1833	u_seri(i,k) = u(i,k)
1834	v_seri(i,k) = v(i,k)
1835	q_seri(i,k) = qx(i,k,ivap)
1836	ql_seri(i,k) = qx(i,k,iliq)
1837	!CR: ATTENTION, on rajoute la variable glace
1838	IF (nqo.eq.2) THEN
1839	qs_seri(i,k) = 0.
1840	ELSE IF (nqo.eq.3) THEN
1841	qs_seri(i,k) = qx(i,k,isol)
1842	ENDIF
1843	ENDDO
1844	ENDDO
1845	!
1846	!--OB mass fixer
1847	IF (mass_fixer) THEN
1848	!--store initial water burden
1849	qql1(:)=0.0
1850	DO k = 1, klev
1851	qql1(:)=qql1(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k))*zmasse(:,k)
1852	ENDDO
1853	ENDIF
1854	!--fin mass fixer
1855
1856	tke0(:,:)=pbl_tke(:,:,is_ave)
1857	!CR:Nombre de traceurs de l'eau: nqo
1858	! IF (nqtot.GE.3) THEN
1859	IF (nqtot.GE.(nqo+1)) THEN
1860	! DO iq = 3, nqtot
1861	DO iq = nqo+1, nqtot
1862	DO k = 1, klev
1863	DO i = 1, klon
1864	! tr_seri(i,k,iq-2) = qx(i,k,iq)
1865	tr_seri(i,k,iq-nqo) = qx(i,k,iq)
1866	ENDDO
1867	ENDDO
1868	ENDDO
1869	ELSE
1870	DO k = 1, klev
1871	DO i = 1, klon
1872	tr_seri(i,k,1) = 0.0
1873	ENDDO
1874	ENDDO
1875	ENDIF
1876	!
1877	DO i = 1, klon
1878	ztsol(i) = 0.
1879	ENDDO
1880	DO nsrf = 1, nbsrf
1881	DO i = 1, klon
1882	ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
1883	ENDDO
1884	ENDDO
1885	! Initialize variables used for diagnostic purpose
1886	IF (flag_inhib_tend .ne. 0) CALL init_cmp_seri
1887
1888	! Diagnostiquer la tendance dynamique
1889	!
1890	IF (ancien_ok) THEN
1891	!
1892	d_u_dyn(:,:) = (u_seri(:,:)-u_ancien(:,:))/dtime
1893	d_v_dyn(:,:) = (v_seri(:,:)-v_ancien(:,:))/dtime
1894	d_t_dyn(:,:) = (t_seri(:,:)-t_ancien(:,:))/dtime
1895	d_q_dyn(:,:) = (q_seri(:,:)-q_ancien(:,:))/dtime
1896	d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/dtime
1897	d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/dtime
1898	CALL water_int(klon,klev,q_seri,zmasse,zx_tmp_fi2d)
1899	d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/dtime
1900	CALL water_int(klon,klev,ql_seri,zmasse,zx_tmp_fi2d)
1901	d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/dtime
1902	CALL water_int(klon,klev,qs_seri,zmasse,zx_tmp_fi2d)
1903	d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/dtime
1904	! !! RomP >>> td dyn traceur
1905	IF (nqtot.GT.nqo) THEN ! jyg
1906	DO iq = nqo+1, nqtot ! jyg
1907	d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/dtime ! jyg
1908	ENDDO
1909	ENDIF
1910	! !! RomP <<<
1911	ELSE
1912	d_u_dyn(:,:) = 0.0
1913	d_v_dyn(:,:) = 0.0
1914	d_t_dyn(:,:) = 0.0
1915	d_q_dyn(:,:) = 0.0
1916	d_ql_dyn(:,:) = 0.0
1917	d_qs_dyn(:,:) = 0.0
1918	d_q_dyn2d(:) = 0.0
1919	d_ql_dyn2d(:) = 0.0
1920	d_qs_dyn2d(:) = 0.0
1921	! !! RomP >>> td dyn traceur
1922	IF (nqtot.GT.nqo) THEN ! jyg
1923	DO iq = nqo+1, nqtot ! jyg
1924	d_tr_dyn(:,:,iq-nqo)= 0.0 ! jyg
1925	ENDDO
1926	ENDIF
1927	! !! RomP <<<
1928	ancien_ok = .TRUE.
1929	ENDIF
1930	!
1931	! Ajouter le geopotentiel du sol:
1932	!
1933	DO k = 1, klev
1934	DO i = 1, klon
1935	zphi(i,k) = pphi(i,k) + pphis(i)
1936	ENDDO
1937	ENDDO
1938	!
1939	! Verifier les temperatures
1940	!
1941	!IM BEG
1942	IF (check) THEN
1943	amn=MIN(ftsol(1,is_ter),1000.)
1944	amx=MAX(ftsol(1,is_ter),-1000.)
1945	DO i=2, klon
1946	amn=MIN(ftsol(i,is_ter),amn)
1947	amx=MAX(ftsol(i,is_ter),amx)
1948	ENDDO
1949	!
1950	PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
1951	ENDIF !(check) THEN
1952	!IM END
1953	!
1954	CALL hgardfou(t_seri,ftsol,'debutphy',abortphy)
1955	IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy'
1956
1957	!
1958	!IM BEG
1959	IF (check) THEN
1960	amn=MIN(ftsol(1,is_ter),1000.)
1961	amx=MAX(ftsol(1,is_ter),-1000.)
1962	DO i=2, klon
1963	amn=MIN(ftsol(i,is_ter),amn)
1964	amx=MAX(ftsol(i,is_ter),amx)
1965	ENDDO
1966	!
1967	PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
1968	ENDIF !(check) THEN
1969	!IM END
1970	!
1971	! Mettre en action les conditions aux limites (albedo, sst, etc.).
1972	! Prescrire l'ozone et calculer l'albedo sur l'ocean.
1973	!
1974	! Update ozone if day change
1975	IF (MOD(itap-1,lmt_pas) == 0) THEN
1976	IF (read_climoz <= 0) THEN
1977	! Once per day, update ozone from Royer:
1978	IF (solarlong0<-999.) then
1979	! Generic case with evolvoing season
1980	zzz=real(days_elapsed+1)
1981	ELSE IF (abs(solarlong0-1000.)<1.e-4) then
1982	! Particular case with annual mean insolation
1983	zzz=real(90) ! could be revisited
1984	IF (read_climoz/=-1) THEN
1985	abort_message ='read_climoz=-1 is recommended when ' &
1986	// 'solarlong0=1000.'
1987	CALL abort_physic (modname,abort_message,1)
1988	ENDIF
1989	ELSE
1990	! Case where the season is imposed with solarlong0
1991	zzz=real(90) ! could be revisited
1992	ENDIF
1993
1994	wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz)
1995	ELSE
1996	!--- ro3i = elapsed days number since current year 1st january, 0h
1997	ro3i=days_elapsed+jh_cur-jh_1jan
1998	!--- scaling for old style files (360 records)
1999	IF(SIZE(time_climoz)==360.AND..NOT.ok_daily_climoz) ro3i=ro3i*360./year_len
2000	IF(adjust_tropopause) THEN
2001	CALL dyn_tropopause(t_seri, ztsol, paprs, pplay, presnivs, rot, &
2002	pr_tropopause)
2003	CALL regr_pr_time_av(ncid_climoz, vars_climoz(1:read_climoz), &
2004	ro3i, press_edg_climoz, paprs, wo, time_climoz, &
2005	latitude_deg, press_cen_climoz, pr_tropopause)
2006	ELSE
2007	CALL regr_pr_time_av(ncid_climoz, vars_climoz(1:read_climoz), &
2008	ro3i, press_edg_climoz, paprs, wo, time_climoz)
2009	END IF
2010	! Convert from mole fraction of ozone to column density of ozone in a
2011	! cell, in kDU:
2012	FORALL (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd &
2013	* zmasse / dobson_u / 1e3
2014	! (By regridding ozone values for LMDZ only once a day, we
2015	! have already neglected the variation of pressure in one
2016	! day. So do not recompute "wo" at each time step even if
2017	! "zmasse" changes a little.)
2018	ENDIF
2019	ENDIF
2020	!
2021	! Re-evaporer l'eau liquide nuageuse
2022	!
2023	CALL reevap (klon,klev,iflag_ice_thermo,t_seri,q_seri,ql_seri,qs_seri, &
2024	& d_t_eva,d_q_eva,d_ql_eva,d_qi_eva)
2025
2026	CALL add_phys_tend &
2027	(du0,dv0,d_t_eva,d_q_eva,d_ql_eva,d_qi_eva,paprs,&
2028	'eva',abortphy,flag_inhib_tend,itap,0)
2029	call prt_enerbil('eva',itap)
2030
2031	!=========================================================================
2032	! Calculs de l'orbite.
2033	! Necessaires pour le rayonnement et la surface (calcul de l'albedo).
2034	! doit donc etre plac\'e avant radlwsw et pbl_surface
2035
2036	! !! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2037	CALL ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq)
2038	day_since_equinox = (jD_cur + jH_cur) - jD_eq
2039	!
2040	! choix entre calcul de la longitude solaire vraie ou valeur fixee a
2041	! solarlong0
2042	IF (solarlong0<-999.) THEN
2043	IF (new_orbit) THEN
2044	! calcul selon la routine utilisee pour les planetes
2045	CALL solarlong(day_since_equinox, zlongi, dist)
2046	ELSE
2047	! calcul selon la routine utilisee pour l'AR4
2048	CALL orbite(REAL(days_elapsed+1),zlongi,dist)
2049	ENDIF
2050	ELSE
2051	zlongi=solarlong0 ! longitude solaire vraie
2052	dist=1. ! distance au soleil / moyenne
2053	ENDIF
2054
2055	IF (prt_level.ge.1) write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist
2056
2057
2058	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2059	! Calcul de l'ensoleillement :
2060	! ============================
2061	! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur
2062	! l'annee a partir d'une formule analytique.
2063	! Cet ensoleillement est sym\'etrique autour de l'\'equateur et
2064	! non nul aux poles.
2065	IF (abs(solarlong0-1000.)<1.e-4) THEN
2066	CALL zenang_an(iflag_cycle_diurne.GE.1,jH_cur, &
2067	latitude_deg,longitude_deg,rmu0,fract)
2068	JrNt = 1.0
2069	ELSE
2070	! recode par Olivier Boucher en sept 2015
2071	SELECT CASE (iflag_cycle_diurne)
2072	CASE(0)
2073	! Sans cycle diurne
2074	CALL angle(zlongi, latitude_deg, fract, rmu0)
2075	swradcorr = 1.0
2076	JrNt = 1.0
2077	zrmu0 = rmu0
2078	CASE(1)
2079	! Avec cycle diurne sans application des poids
2080	! bit comparable a l ancienne formulation cycle_diurne=true
2081	! on integre entre gmtime et gmtime+radpas
2082	zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s)
2083	CALL zenang(zlongi,jH_cur,0.0,zdtime, &
2084	latitude_deg,longitude_deg,rmu0,fract)
2085	zrmu0 = rmu0
2086	swradcorr = 1.0
2087	! Calcul du flag jour-nuit
2088	JrNt = 0.0
2089	WHERE (fract.GT.0.0) JrNt = 1.0
2090	CASE(2)
2091	! Avec cycle diurne sans application des poids
2092	! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1)
2093	! Comme cette routine est appele a tous les pas de temps de
2094	! la physique meme si le rayonnement n'est pas appele je
2095	! remonte en arriere les radpas-1 pas de temps
2096	! suivant. Petite ruse avec MOD pour prendre en compte le
2097	! premier pas de temps de la physique pendant lequel
2098	! itaprad=0
2099	zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1)
2100	zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1)
2101	CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
2102	latitude_deg,longitude_deg,rmu0,fract)
2103	!
2104	! Calcul des poids
2105	!
2106	zdtime1=-dtime !--on corrige le rayonnement pour representer le
2107	zdtime2=0.0 !--pas de temps de la physique qui se termine
2108	CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
2109	latitude_deg,longitude_deg,zrmu0,zfract)
2110	swradcorr = 0.0
2111	WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) &
2112	swradcorr=zfract/fract*zrmu0/rmu0
2113	! Calcul du flag jour-nuit
2114	JrNt = 0.0
2115	WHERE (zfract.GT.0.0) JrNt = 1.0
2116	END SELECT
2117	ENDIF
2118
2119	IF (mydebug) THEN
2120	CALL writefield_phy('u_seri',u_seri,nbp_lev)
2121	CALL writefield_phy('v_seri',v_seri,nbp_lev)
2122	CALL writefield_phy('t_seri',t_seri,nbp_lev)
2123	CALL writefield_phy('q_seri',q_seri,nbp_lev)
2124	ENDIF
2125
2126	!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
2127	! Appel au pbl_surface : Planetary Boudary Layer et Surface
2128	! Cela implique tous les interactions des sous-surfaces et la
2129	! partie diffusion turbulent du couche limit.
2130	!
2131	! Certains varibales de sorties de pbl_surface sont utiliser que pour
2132	! ecriture des fihiers hist_XXXX.nc, ces sont :
2133	! qsol, zq2m, s_pblh, s_lcl,
2134	! s_capCL, s_oliqCL, s_cteiCL,s_pblT,
2135	! s_therm, s_trmb1, s_trmb2, s_trmb3,
2136	! zu10m, zv10m, fder,
2137	! zxqsurf, rh2m, zxfluxu, zxfluxv,
2138	! frugs, agesno, fsollw, fsolsw,
2139	! d_ts, fevap, fluxlat, t2m,
2140	! wfbils, wfbilo, fluxt, fluxu, fluxv,
2141	!
2142	! Certains ne sont pas utiliser du tout :
2143	! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
2144	!
2145
2146	! Calcul de l'humidite de saturation au niveau du sol
2147
2148
2149
2150	IF (iflag_pbl/=0) THEN
2151
2152	!jyg+nrlmd<
2153	!!jyg IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN
2154	IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,10) .ge. 1) THEN
2155	print *,'debut du splitting de la PBL'
2156	ENDIF
2157	! !!
2158	!>jyg+nrlmd
2159	!
2160	!-------gustiness calculation-------!
2161	IF (iflag_gusts==0) THEN
2162	gustiness(1:klon)=0
2163	ELSE IF (iflag_gusts==1) THEN
2164	do i = 1, klon
2165	gustiness(i)=f_gust_blale_bl(i)+f_gust_wkale_wake(i)
2166	enddo
2167	! ELSE IF (iflag_gusts==2) THEN
2168	! do i = 1, klon
2169	! gustiness(i)=f_gust_blale_bl(i)+sigma_wk(i)f_gust_wk&
2170	! *ale_wake(i) !! need to make sigma_wk accessible here
2171	! enddo
2172	! ELSE IF (iflag_gusts==3) THEN
2173	! do i = 1, klon
2174	! gustiness(i)=f_gust_blalp_bl(i)+f_gust_wkalp_wake(i)
2175	! enddo
2176	ENDIF
2177
2178
2179
2180	CALL pbl_surface( &
2181	dtime, date0, itap, days_elapsed+1, &
2182	debut, lafin, &
2183	longitude_deg, latitude_deg, rugoro, zrmu0, &
2184	zsig, sollwdown, pphi, cldt, &
2185	rain_fall, snow_fall, solsw, sollw, &
2186	gustiness, &
2187	t_seri, q_seri, u_seri, v_seri, &
2188	!nrlmd+jyg<
2189	wake_deltat, wake_deltaq, wake_cstar, wake_s, &
2190	!>nrlmd+jyg
2191	pplay, paprs, pctsrf, &
2192	ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, &
2193	!albedo SB <<<
2194	cdragh, cdragm, u1, v1, &
2195	!albedo SB >>>
2196	! albsol1, albsol2, sens, evap, &
2197	albsol_dir, albsol_dif, sens, evap, &
2198	!albedo SB <<<
2199	albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, &
2200	zxtsol, zxfluxlat, zt2m, qsat2m, &
2201	d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, &
2202	!nrlmd<
2203	!jyg<
2204	d_t_vdf_w, d_q_vdf_w, &
2205	d_t_vdf_x, d_q_vdf_x, &
2206	sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, &
2207	!>jyg
2208	delta_tsurf,wake_dens, &
2209	cdragh_x,cdragh_w,cdragm_x,cdragm_w, &
2210	kh,kh_x,kh_w, &
2211	!>nrlmd
2212	coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), &
2213	slab_wfbils, &
2214	qsol, zq2m, s_pblh, s_lcl, &
2215	!jyg<
2216	s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, &
2217	!>jyg
2218	s_capCL, s_oliqCL, s_cteiCL,s_pblT, &
2219	s_therm, s_trmb1, s_trmb2, s_trmb3, &
2220	zustar, zu10m, zv10m, fder, &
2221	zxqsurf, rh2m, zxfluxu, zxfluxv, &
2222	z0m, z0h, agesno, fsollw, fsolsw, &
2223	d_ts, fevap, fluxlat, t2m, &
2224	wfbils, wfbilo, wfevap, wfrain, wfsnow, &
2225	fluxt, fluxu, fluxv, &
2226	dsens, devap, zxsnow, &
2227	zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, &
2228	!nrlmd+jyg<
2229	wake_delta_pbl_TKE &
2230	!>nrlmd+jyg
2231	)
2232	!
2233	! Add turbulent diffusion tendency to the wake difference variables
2234	!!jyg IF (mod(iflag_pbl_split,2) .NE. 0) THEN
2235	IF (mod(iflag_pbl_split,10) .NE. 0) THEN
2236	!jyg<
2237	d_deltat_vdf(:,:) = d_t_vdf_w(:,:)-d_t_vdf_x(:,:)
2238	d_deltaq_vdf(:,:) = d_q_vdf_w(:,:)-d_q_vdf_x(:,:)
2239	CALL add_wake_tend &
2240	(d_deltat_vdf, d_deltaq_vdf, dsig0, ddens0, wkoccur1, 'vdf', abortphy)
2241	ELSE
2242	d_deltat_vdf(:,:) = 0.
2243	d_deltaq_vdf(:,:) = 0.
2244	!>jyg
2245	ENDIF
2246
2247
2248	!---------------------------------------------------------------------
2249	! ajout des tendances de la diffusion turbulente
2250	IF (klon_glo==1) THEN
2251	CALL add_pbl_tend &
2252	(d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,&
2253	'vdf',abortphy,flag_inhib_tend,itap)
2254	ELSE
2255	CALL add_phys_tend &
2256	(d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,&
2257	'vdf',abortphy,flag_inhib_tend,itap,0)
2258	ENDIF
2259	call prt_enerbil('vdf',itap)
2260	!--------------------------------------------------------------------
2261
2262	IF (mydebug) THEN
2263	CALL writefield_phy('u_seri',u_seri,nbp_lev)
2264	CALL writefield_phy('v_seri',v_seri,nbp_lev)
2265	CALL writefield_phy('t_seri',t_seri,nbp_lev)
2266	CALL writefield_phy('q_seri',q_seri,nbp_lev)
2267	ENDIF
2268
2269	!albedo SB >>>
2270	albsol1=0.
2271	albsol2=0.
2272	falb1=0.
2273	falb2=0.
2274	SELECT CASE(nsw)
2275	CASE(2)
2276	albsol1=albsol_dir(:,1)
2277	albsol2=albsol_dir(:,2)
2278	falb1=falb_dir(:,1,:)
2279	falb2=falb_dir(:,2,:)
2280	CASE(4)
2281	albsol1=albsol_dir(:,1)
2282	albsol2=albsol_dir(:,2)SFRWL(2)+albsol_dir(:,3)SFRWL(3) &
2283	+albsol_dir(:,4)*SFRWL(4)
2284	albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
2285	falb1=falb_dir(:,1,:)
2286	falb2=falb_dir(:,2,:)SFRWL(2)+falb_dir(:,3,:)SFRWL(3) &
2287	+falb_dir(:,4,:)*SFRWL(4)
2288	falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
2289	CASE(6)
2290	albsol1=albsol_dir(:,1)SFRWL(1)+albsol_dir(:,2)SFRWL(2) &
2291	+albsol_dir(:,3)*SFRWL(3)
2292	albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
2293	albsol2=albsol_dir(:,4)SFRWL(4)+albsol_dir(:,5)SFRWL(5) &
2294	+albsol_dir(:,6)*SFRWL(6)
2295	albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
2296	falb1=falb_dir(:,1,:)SFRWL(1)+falb_dir(:,2,:)SFRWL(2) &
2297	+falb_dir(:,3,:)*SFRWL(3)
2298	falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
2299	falb2=falb_dir(:,4,:)SFRWL(4)+falb_dir(:,5,:)SFRWL(5) &
2300	+falb_dir(:,6,:)*SFRWL(6)
2301	falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
2302	END SELECt
2303	!albedo SB <<<
2304
2305
2306	CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, &
2307	t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot)
2308
2309	ENDIF
2310	! =================================================================== c
2311	! Calcul de Qsat
2312
2313	DO k = 1, klev
2314	DO i = 1, klon
2315	zx_t = t_seri(i,k)
2316	IF (thermcep) THEN
2317	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
2318	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
2319	zx_qs = MIN(0.5,zx_qs)
2320	zcor = 1./(1.-retv*zx_qs)
2321	zx_qs = zx_qs*zcor
2322	ELSE
2323	!! IF (zx_t.LT.t_coup) THEN !jyg
2324	IF (zx_t.LT.rtt) THEN !jyg
2325	zx_qs = qsats(zx_t)/pplay(i,k)
2326	ELSE
2327	zx_qs = qsatl(zx_t)/pplay(i,k)
2328	ENDIF
2329	ENDIF
2330	zqsat(i,k)=zx_qs
2331	ENDDO
2332	ENDDO
2333
2334	IF (prt_level.ge.1) THEN
2335	write(lunout,*) 'L qsat (g/kg) avant clouds_gno'
2336	write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev)
2337	ENDIF
2338	!
2339	! Appeler la convection (au choix)
2340	!
2341	DO k = 1, klev
2342	DO i = 1, klon
2343	conv_q(i,k) = d_q_dyn(i,k) &
2344	+ d_q_vdf(i,k)/dtime
2345	conv_t(i,k) = d_t_dyn(i,k) &
2346	+ d_t_vdf(i,k)/dtime
2347	ENDDO
2348	ENDDO
2349	IF (check) THEN
2350	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
2351	WRITE(lunout,*) "avantcon=", za
2352	ENDIF
2353	zx_ajustq = .FALSE.
2354	IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
2355	IF (zx_ajustq) THEN
2356	DO i = 1, klon
2357	z_avant(i) = 0.0
2358	ENDDO
2359	DO k = 1, klev
2360	DO i = 1, klon
2361	z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) &
2362	*(paprs(i,k)-paprs(i,k+1))/RG
2363	ENDDO
2364	ENDDO
2365	ENDIF
2366
2367	! Calcule de vitesse verticale a partir de flux de masse verticale
2368	DO k = 1, klev
2369	DO i = 1, klon
2370	omega(i,k) = RG*flxmass_w(i,k) / cell_area(i)
2371	ENDDO
2372	ENDDO
2373
2374	IF (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', &
2375	omega(igout, :)
2376	!
2377	! Appel de la convection tous les "cvpas"
2378	!
2379	IF (MOD(itapcv,cvpas).EQ.0) THEN
2380
2381	IF (iflag_con.EQ.1) THEN
2382	abort_message ='reactiver le call conlmd dans physiq.F'
2383	CALL abort_physic (modname,abort_message,1)
2384	! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
2385	! . d_t_con, d_q_con,
2386	! . rain_con, snow_con, ibas_con, itop_con)
2387	ELSE IF (iflag_con.EQ.2) THEN
2388	CALL conflx(dtime, paprs, pplay, t_seri, q_seri, &
2389	conv_t, conv_q, -evap, omega, &
2390	d_t_con, d_q_con, rain_con, snow_con, &
2391	pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
2392	kcbot, kctop, kdtop, pmflxr, pmflxs)
2393	d_u_con = 0.
2394	d_v_con = 0.
2395
2396	WHERE (rain_con < 0.) rain_con = 0.
2397	WHERE (snow_con < 0.) snow_con = 0.
2398	DO i = 1, klon
2399	ibas_con(i) = klev+1 - kcbot(i)
2400	itop_con(i) = klev+1 - kctop(i)
2401	ENDDO
2402	ELSE IF (iflag_con.GE.3) THEN
2403	! nb of tracers for the KE convection:
2404	! MAF la partie traceurs est faite dans phytrac
2405	! on met ntra=1 pour limiter les appels mais on peut
2406	! supprimer les calculs / ftra.
2407	ntra = 1
2408
2409	!=======================================================================
2410	!ajout pour la parametrisation des poches froides: calcul de
2411	!t_w et t_x: si pas de poches froides, t_w=t_x=t_seri
2412	IF (iflag_wake>=1) THEN
2413	DO k=1,klev
2414	DO i=1,klon
2415	t_w(i,k) = t_seri(i,k) + (1-wake_s(i))*wake_deltat(i,k)
2416	q_w(i,k) = q_seri(i,k) + (1-wake_s(i))*wake_deltaq(i,k)
2417	t_x(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k)
2418	q_x(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k)
2419	ENDDO
2420	ENDDO
2421	ELSE
2422	t_w(:,:) = t_seri(:,:)
2423	q_w(:,:) = q_seri(:,:)
2424	t_x(:,:) = t_seri(:,:)
2425	q_x(:,:) = q_seri(:,:)
2426	ENDIF
2427	!
2428	!jyg<
2429	! Perform dry adiabatic adjustment on wake profile
2430	! The corresponding tendencies are added to the convective tendencies
2431	! after the call to the convective scheme.
2432	IF (iflag_wake>=1) then
2433	IF (iflag_adjwk >= 1) THEN
2434	limbas(:) = 1
2435	CALL ajsec(paprs, pplay, t_w, q_w, limbas, &
2436	d_t_adjwk, d_q_adjwk)
2437	!
2438	DO k=1,klev
2439	DO i=1,klon
2440	IF (wake_s(i) .GT. 1.e-3) THEN
2441	t_w(i,k) = t_w(i,k) + d_t_adjwk(i,k)
2442	q_w(i,k) = q_w(i,k) + d_q_adjwk(i,k)
2443	d_deltat_ajs_cv(i,k) = d_t_adjwk(i,k)
2444	d_deltaq_ajs_cv(i,k) = d_q_adjwk(i,k)
2445	ELSE
2446	d_deltat_ajs_cv(i,k) = 0.
2447	d_deltaq_ajs_cv(i,k) = 0.
2448	ENDIF
2449	ENDDO
2450	ENDDO
2451	IF (iflag_adjwk == 2) THEN
2452	CALL add_wake_tend &
2453	(d_deltat_ajs_cv, d_deltaq_ajs_cv, dsig0, ddens0, wkoccur1, 'ajs_cv', abortphy)
2454	ENDIF ! (iflag_adjwk == 2)
2455	ENDIF ! (iflag_adjwk >= 1)
2456	ENDIF ! (iflag_wake>=1)
2457	!>jyg
2458	!
2459
2460	!! print *,'physiq. q_w(1,k), q_x(1,k) ', &
2461	!! (k, q_w(1,k), q_x(1,k),k=1,25)
2462
2463	!jyg<
2464	CALL alpale( debut, itap, dtime, paprs, omega, t_seri, &
2465	alp_offset, it_wape_prescr, wape_prescr, fip_prescr, &
2466	ale_bl_prescr, alp_bl_prescr, &
2467	wake_pe, wake_fip, &
2468	Ale_bl, Ale_bl_trig, Alp_bl, &
2469	Ale, Alp , Ale_wake, Alp_wake)
2470	!>jyg
2471	!
2472	! sb, oct02:
2473	! Schema de convection modularise et vectorise:
2474	! (driver commun aux versions 3 et 4)
2475	!
2476	IF (ok_cvl) THEN ! new driver for convectL
2477	!
2478	!jyg<
2479	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2480	! Calculate the upmost level of deep convection loops: k_upper_cv
2481	! (near 22 km)
2482	izero = klon/2+1/klon
2483	k_upper_cv = klev
2484	DO k = klev,1,-1
2485	IF (pphi(izero,k) > 22.e4) k_upper_cv = k
2486	ENDDO
2487	IF (prt_level .ge. 5) THEN
2488	Print *, 'upmost level of deep convection loops: k_upper_cv = ', &
2489	k_upper_cv
2490	ENDIF
2491	!
2492	!>jyg
2493	IF (type_trac == 'repr') THEN
2494	nbtr_tmp=ntra
2495	ELSE
2496	nbtr_tmp=nbtr
2497	ENDIF
2498	!jyg iflag_con est dans clesphys
2499	!c CALL concvl (iflag_con,iflag_clos,
2500	CALL concvl (iflag_clos, &
2501	dtime, paprs, pplay, k_upper_cv, t_x,q_x, &
2502	t_w,q_w,wake_s, &
2503	u_seri,v_seri,tr_seri,nbtr_tmp, &
2504	ALE,ALP, &
2505	sig1,w01, &
2506	d_t_con,d_q_con,d_u_con,d_v_con,d_tr, &
2507	rain_con, snow_con, ibas_con, itop_con, sigd, &
2508	ema_cbmf,plcl,plfc,wbeff,convoccur,upwd,dnwd,dnwd0, &
2509	Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, &
2510	pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, &
2511	! RomP >>>
2512	!! . pmflxr,pmflxs,da,phi,mp,
2513	!! . ftd,fqd,lalim_conv,wght_th)
2514	pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, &
2515	ftd,fqd,lalim_conv,wght_th, &
2516	ev, ep,epmlmMm,eplaMm, &
2517	wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, &
2518	tau_cld_cv,coefw_cld_cv,epmax_diag)
2519
2520	! RomP <<<
2521
2522	!IM begin
2523	! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1),
2524	! .dnwd0(1,1),ftd(1,1),fqd(1,1)
2525	!IM end
2526	!IM cf. FH
2527	clwcon0=qcondc
2528	pmfu(:,:)=upwd(:,:)+dnwd(:,:)
2529
2530	DO i = 1, klon
2531	IF (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1
2532	ENDDO
2533	!
2534	!jyg<
2535	! Add the tendency due to the dry adjustment of the wake profile
2536	IF (iflag_wake>=1) THEN
2537	IF (iflag_adjwk == 2) THEN
2538	DO k=1,klev
2539	DO i=1,klon
2540	ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime
2541	fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime
2542	d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k)
2543	d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k)
2544	ENDDO
2545	ENDDO
2546	ENDIF ! (iflag_adjwk = 2)
2547	ENDIF ! (iflag_wake>=1)
2548	!>jyg
2549	!
2550	ELSE ! ok_cvl
2551
2552	! MAF conema3 ne contient pas les traceurs
2553	CALL conema3 (dtime, &
2554	paprs,pplay,t_seri,q_seri, &
2555	u_seri,v_seri,tr_seri,ntra, &
2556	sig1,w01, &
2557	d_t_con,d_q_con,d_u_con,d_v_con,d_tr, &
2558	rain_con, snow_con, ibas_con, itop_con, &
2559	upwd,dnwd,dnwd0,bas,top, &
2560	Ma,cape,tvp,rflag, &
2561	pbase &
2562	,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr &
2563	,clwcon0)
2564
2565	ENDIF ! ok_cvl
2566
2567	!
2568	! Correction precip
2569	rain_con = rain_con * cvl_corr
2570	snow_con = snow_con * cvl_corr
2571	!
2572
2573	IF (.NOT. ok_gust) THEN
2574	do i = 1, klon
2575	wd(i)=0.0
2576	enddo
2577	ENDIF
2578
2579	! =================================================================== c
2580	! Calcul des proprietes des nuages convectifs
2581	!
2582
2583	! calcul des proprietes des nuages convectifs
2584	clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
2585	IF (iflag_cld_cv == 0) THEN
2586	CALL clouds_gno &
2587	(klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
2588	ELSE
2589	CALL clouds_bigauss &
2590	(klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0)
2591	ENDIF
2592
2593
2594	! =================================================================== c
2595
2596	DO i = 1, klon
2597	itop_con(i) = min(max(itop_con(i),1),klev)
2598	ibas_con(i) = min(max(ibas_con(i),1),itop_con(i))
2599	ENDDO
2600
2601	DO i = 1, klon
2602	ema_pcb(i) = paprs(i,ibas_con(i))
2603	ENDDO
2604	DO i = 1, klon
2605	! L'idicage de itop_con peut cacher un pb potentiel
2606	! FH sous la dictee de JYG, CR
2607	ema_pct(i) = paprs(i,itop_con(i)+1)
2608
2609	IF (itop_con(i).gt.klev-3) THEN
2610	IF (prt_level >= 9) THEN
2611	write(lunout,*)'La convection monte trop haut '
2612	write(lunout,*)'itop_con(,',i,',)=',itop_con(i)
2613	ENDIF
2614	ENDIF
2615	ENDDO
2616	ELSE IF (iflag_con.eq.0) THEN
2617	write(lunout,*) 'On n appelle pas la convection'
2618	clwcon0=0.
2619	rnebcon0=0.
2620	d_t_con=0.
2621	d_q_con=0.
2622	d_u_con=0.
2623	d_v_con=0.
2624	rain_con=0.
2625	snow_con=0.
2626	bas=1
2627	top=1
2628	ELSE
2629	WRITE(lunout,*) "iflag_con non-prevu", iflag_con
2630	CALL abort_physic("physiq", "", 1)
2631	ENDIF
2632
2633	! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
2634	! . d_u_con, d_v_con)
2635
2636	!jyg Reinitialize proba_notrig and itapcv when convection has been called
2637	proba_notrig(:) = 1.
2638	itapcv = 0
2639	ENDIF ! (MOD(itapcv,cvpas).EQ.0)
2640	!
2641	itapcv = itapcv+1
2642
2643	!!!jyg Appel diagnostique a add_phys_tend pour tester la conservation de
2644	!!! l'energie dans les courants satures.
2645	!! d_t_con_sat(:,:) = d_t_con(:,:) - ftd(:,:)*dtime
2646	!! d_q_con_sat(:,:) = d_q_con(:,:) - fqd(:,:)*dtime
2647	!! dql_sat(:,:) = (wdtrainA(:,:)+wdtrainM(:,:))*dtime/zmasse(:,:)
2648	!! CALL add_phys_tend(d_u_con, d_v_con, d_t_con_sat, d_q_con_sat, dql_sat, &
2649	!! dqi0, paprs, 'convection_sat', abortphy, flag_inhib_tend,&
2650	!! itap, 1)
2651	!! call prt_enerbil('convection_sat',itap)
2652	!!
2653	!!
2654	CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, &
2655	'convection',abortphy,flag_inhib_tend,itap,0)
2656	call prt_enerbil('convection',itap)
2657
2658	!-------------------------------------------------------------------------
2659
2660	IF (mydebug) THEN
2661	CALL writefield_phy('u_seri',u_seri,nbp_lev)
2662	CALL writefield_phy('v_seri',v_seri,nbp_lev)
2663	CALL writefield_phy('t_seri',t_seri,nbp_lev)
2664	CALL writefield_phy('q_seri',q_seri,nbp_lev)
2665	ENDIF
2666
2667	IF (check) THEN
2668	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
2669	WRITE(lunout,*)"aprescon=", za
2670	zx_t = 0.0
2671	za = 0.0
2672	DO i = 1, klon
2673	za = za + cell_area(i)/REAL(klon)
2674	zx_t = zx_t + (rain_con(i)+ &
2675	snow_con(i))*cell_area(i)/REAL(klon)
2676	ENDDO
2677	zx_t = zx_t/za*dtime
2678	WRITE(lunout,*)"Precip=", zx_t
2679	ENDIF
2680	IF (zx_ajustq) THEN
2681	DO i = 1, klon
2682	z_apres(i) = 0.0
2683	ENDDO
2684	DO k = 1, klev
2685	DO i = 1, klon
2686	z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) &
2687	*(paprs(i,k)-paprs(i,k+1))/RG
2688	ENDDO
2689	ENDDO
2690	DO i = 1, klon
2691	z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) &
2692	/z_apres(i)
2693	ENDDO
2694	DO k = 1, klev
2695	DO i = 1, klon
2696	IF (z_factor(i).GT.(1.0+1.0E-08) .OR. &
2697	z_factor(i).LT.(1.0-1.0E-08)) THEN
2698	q_seri(i,k) = q_seri(i,k) * z_factor(i)
2699	ENDIF
2700	ENDDO
2701	ENDDO
2702	ENDIF
2703	zx_ajustq=.FALSE.
2704
2705	!
2706	!==========================================================================
2707	!RR:Evolution de la poche froide: on ne fait pas de separation wake/env
2708	!pour la couche limite diffuse pour l instant
2709	!
2710	!
2711	! nrlmd le 22/03/2011---Si on met les poches hors des thermiques
2712	! il faut rajouter cette tendance calcul\'ee hors des poches
2713	! froides
2714	!
2715	IF (iflag_wake>=1) THEN
2716	!
2717	!
2718	! Call wakes every "wkpas" step
2719	!
2720	IF (MOD(itapwk,wkpas).EQ.0) THEN
2721	!
2722	DO k=1,klev
2723	DO i=1,klon
2724	dt_dwn(i,k) = ftd(i,k)
2725	dq_dwn(i,k) = fqd(i,k)
2726	M_dwn(i,k) = dnwd0(i,k)
2727	M_up(i,k) = upwd(i,k)
2728	dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k)
2729	dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k)
2730	ENDDO
2731	ENDDO
2732
2733	IF (iflag_wake==2) THEN
2734	ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.)
2735	DO k = 1,klev
2736	dt_dwn(:,k)= dt_dwn(:,k)+ &
2737	ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime
2738	dq_dwn(:,k)= dq_dwn(:,k)+ &
2739	ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime
2740	ENDDO
2741	ELSEIF (iflag_wake==3) THEN
2742	ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.)
2743	DO k = 1,klev
2744	DO i=1,klon
2745	IF (rneb(i,k)==0.) THEN
2746	! On ne tient compte des tendances qu'en dehors des
2747	! nuages (c'est-\`a-dire a priri dans une region ou
2748	! l'eau se reevapore).
2749	dt_dwn(i,k)= dt_dwn(i,k)+ &
2750	ok_wk_lsp(i)*d_t_lsc(i,k)/dtime
2751	dq_dwn(i,k)= dq_dwn(i,k)+ &
2752	ok_wk_lsp(i)*d_q_lsc(i,k)/dtime
2753	ENDIF
2754	ENDDO
2755	ENDDO
2756	ENDIF
2757
2758	!
2759	!calcul caracteristiques de la poche froide
2760	CALL calWAKE (iflag_wake_tend, paprs, pplay, dtime, &
2761	t_seri, q_seri, omega, &
2762	dt_dwn, dq_dwn, M_dwn, M_up, &
2763	dt_a, dq_a, &
2764	sigd, &
2765	wake_deltat, wake_deltaq, wake_s, wake_dens, &
2766	wake_dth, wake_h, &
2767	wake_pe, wake_fip, wake_gfl, &
2768	d_t_wake, d_q_wake, &
2769	wake_k, t_x, q_x, &
2770	wake_omgbdth, wake_dp_omgb, &
2771	wake_dtKE, wake_dqKE, &
2772	wake_omg, wake_dp_deltomg, &
2773	wake_spread, wake_Cstar, d_deltat_wk_gw, &
2774	d_deltat_wk, d_deltaq_wk, d_s_wk, d_dens_wk)
2775	!
2776	!jyg Reinitialize itapwk when wakes have been called
2777	itapwk = 0
2778	ENDIF ! (MOD(itapwk,wkpas).EQ.0)
2779	!
2780	itapwk = itapwk+1
2781	!
2782	!-----------------------------------------------------------------------
2783	! ajout des tendances des poches froides
2784	CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake', &
2785	abortphy,flag_inhib_tend,itap,0)
2786	call prt_enerbil('wake',itap)
2787	!------------------------------------------------------------------------
2788
2789	! Increment Wake state variables
2790	IF (iflag_wake_tend .GT. 0.) THEN
2791
2792	CALL add_wake_tend &
2793	(d_deltat_wk, d_deltaq_wk, d_s_wk, d_dens_wk, wake_k, &
2794	'wake', abortphy)
2795	call prt_enerbil('wake',itap)
2796	ENDIF ! (iflag_wake_tend .GT. 0.)
2797
2798	ENDIF ! (iflag_wake>=1)
2799	!
2800	!===================================================================
2801	! Convection seche (thermiques ou ajustement)
2802	!===================================================================
2803	!
2804	CALL stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri &
2805	,seuil_inversion,weak_inversion,dthmin)
2806
2807
2808
2809	d_t_ajsb(:,:)=0.
2810	d_q_ajsb(:,:)=0.
2811	d_t_ajs(:,:)=0.
2812	d_u_ajs(:,:)=0.
2813	d_v_ajs(:,:)=0.
2814	d_q_ajs(:,:)=0.
2815	clwcon0th(:,:)=0.
2816	!
2817	! fm_therm(:,:)=0.
2818	! entr_therm(:,:)=0.
2819	! detr_therm(:,:)=0.
2820	!
2821	IF (prt_level>9) WRITE(lunout,*) &
2822	'AVANT LA CONVECTION SECHE , iflag_thermals=' &
2823	,iflag_thermals,' nsplit_thermals=',nsplit_thermals
2824	IF (iflag_thermals<0) THEN
2825	! Rien
2826	! ====
2827	IF (prt_level>9) WRITE(lunout,*)'pas de convection seche'
2828
2829
2830	ELSE
2831
2832	! Thermiques
2833	! ==========
2834	IF (prt_level>9) WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' &
2835	,iflag_thermals,' nsplit_thermals=',nsplit_thermals
2836
2837
2838	!cc nrlmd le 10/04/2012
2839	DO k=1,klev+1
2840	DO i=1,klon
2841	pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce)
2842	pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter)
2843	pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic)
2844	pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic)
2845	ENDDO
2846	ENDDO
2847	!cc fin nrlmd le 10/04/2012
2848
2849	IF (iflag_thermals>=1) THEN
2850	!jyg<
2851	!! IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
2852	IF (mod(iflag_pbl_split/10,10) .GE. 1) THEN
2853	! Appel des thermiques avec les profils exterieurs aux poches
2854	DO k=1,klev
2855	DO i=1,klon
2856	t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k)
2857	q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k)
2858	u_therm(i,k) = u_seri(i,k)
2859	v_therm(i,k) = v_seri(i,k)
2860	ENDDO
2861	ENDDO
2862	ELSE
2863	! Appel des thermiques avec les profils moyens
2864	DO k=1,klev
2865	DO i=1,klon
2866	t_therm(i,k) = t_seri(i,k)
2867	q_therm(i,k) = q_seri(i,k)
2868	u_therm(i,k) = u_seri(i,k)
2869	v_therm(i,k) = v_seri(i,k)
2870	ENDDO
2871	ENDDO
2872	ENDIF
2873	!>jyg
2874	CALL calltherm(pdtphys &
2875	,pplay,paprs,pphi,weak_inversion &
2876	! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg
2877	,u_therm,v_therm,t_therm,q_therm,zqsat,debut & !jyg
2878	,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs &
2879	,fm_therm,entr_therm,detr_therm &
2880	,zqasc,clwcon0th,lmax_th,ratqscth &
2881	,ratqsdiff,zqsatth &
2882	!on rajoute ale et alp, et les
2883	!caracteristiques de la couche alim
2884	,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca &
2885	,ztv,zpspsk,ztla,zthl &
2886	!cc nrlmd le 10/04/2012
2887	,pbl_tke_input,pctsrf,omega,cell_area &
2888	,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &
2889	,n2,s2,ale_bl_stat &
2890	,therm_tke_max,env_tke_max &
2891	,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &
2892	,alp_bl_conv,alp_bl_stat &
2893	!cc fin nrlmd le 10/04/2012
2894	,zqla,ztva )
2895	!
2896	!jyg<
2897	!!jyg IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
2898	IF (mod(iflag_pbl_split/10,10) .GE. 1) THEN
2899	! Si les thermiques ne sont presents que hors des
2900	! poches, la tendance moyenne associ\'ee doit etre
2901	! multipliee par la fraction surfacique qu'ils couvrent.
2902	DO k=1,klev
2903	DO i=1,klon
2904	!
2905	d_deltat_the(i,k) = - d_t_ajs(i,k)
2906	d_deltaq_the(i,k) = - d_q_ajs(i,k)
2907	!
2908	d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i))
2909	d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i))
2910	d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i))
2911	d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i))
2912	!
2913	ENDDO
2914	ENDDO
2915	!
2916	CALL add_wake_tend &
2917	(d_deltat_the, d_deltaq_the, dsig0, ddens0, wkoccur1, 'the', abortphy)
2918	call prt_enerbil('the',itap)
2919	!
2920	ENDIF ! (mod(iflag_pbl_split/10,10) .GE. 1)
2921	!
2922	CALL add_phys_tend(d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs, &
2923	dql0,dqi0,paprs,'thermals', abortphy,flag_inhib_tend,itap,0)
2924	call prt_enerbil('thermals',itap)
2925	!
2926	!
2927	CALL alpale_th( dtime, lmax_th, t_seri, cell_area, &
2928	cin, s2, n2, &
2929	ale_bl_trig, ale_bl_stat, ale_bl, &
2930	alp_bl, alp_bl_stat, &
2931	proba_notrig, random_notrig)
2932	!>jyg
2933
2934	! ------------------------------------------------------------------
2935	! Transport de la TKE par les panaches thermiques.
2936	! FH : 2010/02/01
2937	! if (iflag_pbl.eq.10) then
2938	! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,
2939	! s rg,paprs,pbl_tke)
2940	! endif
2941	! -------------------------------------------------------------------
2942
2943	DO i=1,klon
2944	! zmax_th(i)=pphi(i,lmax_th(i))/rg
2945	!CR:04/05/12:correction calcul zmax
2946	zmax_th(i)=zmax0(i)
2947	ENDDO
2948
2949	ENDIF
2950
2951	! Ajustement sec
2952	! ==============
2953
2954	! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement
2955	! a partir du sommet des thermiques.
2956	! Dans le cas contraire, on demarre au niveau 1.
2957
2958	IF (iflag_thermals>=13.or.iflag_thermals<=0) THEN
2959
2960	IF (iflag_thermals.eq.0) THEN
2961	IF (prt_level>9) WRITE(lunout,*)'ajsec'
2962	limbas(:)=1
2963	ELSE
2964	limbas(:)=lmax_th(:)
2965	ENDIF
2966
2967	! Attention : le call ajsec_convV2 n'est maintenu que momentanneement
2968	! pour des test de convergence numerique.
2969	! Le nouveau ajsec est a priori mieux, meme pour le cas
2970	! iflag_thermals = 0 (l'ancienne version peut faire des tendances
2971	! non nulles numeriquement pour des mailles non concernees.
2972
2973	IF (iflag_thermals==0) THEN
2974	! Calling adjustment alone (but not the thermal plume model)
2975	CALL ajsec_convV2(paprs, pplay, t_seri,q_seri &
2976	, d_t_ajsb, d_q_ajsb)
2977	ELSE IF (iflag_thermals>0) THEN
2978	! Calling adjustment above the top of thermal plumes
2979	CALL ajsec(paprs, pplay, t_seri,q_seri,limbas &
2980	, d_t_ajsb, d_q_ajsb)
2981	ENDIF
2982
2983	!--------------------------------------------------------------------
2984	! ajout des tendances de l'ajustement sec ou des thermiques
2985	CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs, &
2986	'ajsb',abortphy,flag_inhib_tend,itap,0)
2987	call prt_enerbil('ajsb',itap)
2988	d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
2989	d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
2990
2991	!---------------------------------------------------------------------
2992
2993	ENDIF
2994
2995	ENDIF
2996	!
2997	!===================================================================
2998	! Computation of ratqs, the width (normalized) of the subrid scale
2999	! water distribution
3000	CALL calcratqs(klon,klev,prt_level,lunout, &
3001	iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
3002	ratqsbas,ratqshaut,ratqsp0, ratqsdp, &
3003	tau_ratqs,fact_cldcon, &
3004	ptconv,ptconvth,clwcon0th, rnebcon0th, &
3005	paprs,pplay,q_seri,zqsat,fm_therm, &
3006	ratqs,ratqsc)
3007
3008
3009	!
3010	! Appeler le processus de condensation a grande echelle
3011	! et le processus de precipitation
3012	!-------------------------------------------------------------------------
3013	IF (prt_level .GE.10) THEN
3014	print *,'itap, ->fisrtilp ',itap
3015	ENDIF
3016	!
3017	CALL fisrtilp(dtime,paprs,pplay, &
3018	t_seri, q_seri,ptconv,ratqs, &
3019	d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, &
3020	rain_lsc, snow_lsc, &
3021	pfrac_impa, pfrac_nucl, pfrac_1nucl, &
3022	frac_impa, frac_nucl, beta_prec_fisrt, &
3023	prfl, psfl, rhcl, &
3024	zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, &
3025	iflag_ice_thermo)
3026	!
3027	WHERE (rain_lsc < 0) rain_lsc = 0.
3028	WHERE (snow_lsc < 0) snow_lsc = 0.
3029
3030	!+JLD
3031	! write(*,9000) 'phys lsc',"enerbil: bil_q, bil_e,",rain_lsc+snow_lsc &
3032	! & ,((rcw-rcpd)rain_lsc + (rcs-rcpd)snow_lsc)t_seri(1,1)-rlvttrain_lsc+rlstt*snow_lsc &
3033	! & ,rain_lsc,snow_lsc
3034	! write(*,9000) "rcpv","rcw",rcpv,rcw,rcs,t_seri(1,1)
3035	!-JLD
3036	CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs, &
3037	'lsc',abortphy,flag_inhib_tend,itap,0)
3038	call prt_enerbil('lsc',itap)
3039	rain_num(:)=0.
3040	DO k = 1, klev
3041	DO i = 1, klon
3042	IF (ql_seri(i,k)>oliqmax) THEN
3043	rain_num(i)=rain_num(i)+(ql_seri(i,k)-oliqmax)*zmasse(i,k)/pdtphys
3044	ql_seri(i,k)=oliqmax
3045	ENDIF
3046	ENDDO
3047	ENDDO
3048	IF (nqo==3) THEN
3049	DO k = 1, klev
3050	DO i = 1, klon
3051	IF (qs_seri(i,k)>oicemax) THEN
3052	rain_num(i)=rain_num(i)+(qs_seri(i,k)-oicemax)*zmasse(i,k)/pdtphys
3053	qs_seri(i,k)=oicemax
3054	ENDIF
3055	ENDDO
3056	ENDDO
3057	ENDIF
3058
3059	!---------------------------------------------------------------------------
3060	DO k = 1, klev
3061	DO i = 1, klon
3062	cldfra(i,k) = rneb(i,k)
3063	!CR: a quoi ca sert? Faut-il ajouter qs_seri?
3064	IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
3065	ENDDO
3066	ENDDO
3067	IF (check) THEN
3068	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
3069	WRITE(lunout,*)"apresilp=", za
3070	zx_t = 0.0
3071	za = 0.0
3072	DO i = 1, klon
3073	za = za + cell_area(i)/REAL(klon)
3074	zx_t = zx_t + (rain_lsc(i) &
3075	+ snow_lsc(i))*cell_area(i)/REAL(klon)
3076	ENDDO
3077	zx_t = zx_t/za*dtime
3078	WRITE(lunout,*)"Precip=", zx_t
3079	ENDIF
3080
3081	IF (mydebug) THEN
3082	CALL writefield_phy('u_seri',u_seri,nbp_lev)
3083	CALL writefield_phy('v_seri',v_seri,nbp_lev)
3084	CALL writefield_phy('t_seri',t_seri,nbp_lev)
3085	CALL writefield_phy('q_seri',q_seri,nbp_lev)
3086	ENDIF
3087
3088	!
3089	!-------------------------------------------------------------------
3090	! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
3091	!-------------------------------------------------------------------
3092
3093	! 1. NUAGES CONVECTIFS
3094	!
3095	!IM cf FH
3096	! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke
3097	IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke
3098	snow_tiedtke=0.
3099	! print*,'avant calcul de la pseudo precip '
3100	! print*,'iflag_cld_th',iflag_cld_th
3101	IF (iflag_cld_th.eq.-1) THEN
3102	rain_tiedtke=rain_con
3103	ELSE
3104	! print*,'calcul de la pseudo precip '
3105	rain_tiedtke=0.
3106	! print*,'calcul de la pseudo precip 0'
3107	DO k=1,klev
3108	DO i=1,klon
3109	IF (d_q_con(i,k).lt.0.) THEN
3110	rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys &
3111	*(paprs(i,k)-paprs(i,k+1))/rg
3112	ENDIF
3113	ENDDO
3114	ENDDO
3115	ENDIF
3116	!
3117	! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
3118	!
3119
3120	! Nuages diagnostiques pour Tiedtke
3121	CALL diagcld1(paprs,pplay, &
3122	!IM cf FH. rain_con,snow_con,ibas_con,itop_con,
3123	rain_tiedtke,snow_tiedtke,ibas_con,itop_con, &
3124	diafra,dialiq)
3125	DO k = 1, klev
3126	DO i = 1, klon
3127	IF (diafra(i,k).GT.cldfra(i,k)) THEN
3128	cldliq(i,k) = dialiq(i,k)
3129	cldfra(i,k) = diafra(i,k)
3130	ENDIF
3131	ENDDO
3132	ENDDO
3133
3134	ELSE IF (iflag_cld_th.ge.3) THEN
3135	! On prend pour les nuages convectifs le max du calcul de la
3136	! convection et du calcul du pas de temps precedent diminue d'un facteur
3137	! facttemps
3138	facteur = pdtphys *facttemps
3139	DO k=1,klev
3140	DO i=1,klon
3141	rnebcon(i,k)=rnebcon(i,k)*facteur
3142	IF (rnebcon0(i,k)clwcon0(i,k).GT.rnebcon(i,k)clwcon(i,k)) THEN
3143	rnebcon(i,k)=rnebcon0(i,k)
3144	clwcon(i,k)=clwcon0(i,k)
3145	ENDIF
3146	ENDDO
3147	ENDDO
3148
3149	! On prend la somme des fractions nuageuses et des contenus en eau
3150
3151	IF (iflag_cld_th>=5) THEN
3152
3153	DO k=1,klev
3154	ptconvth(:,k)=fm_therm(:,k+1)>0.
3155	ENDDO
3156
3157	IF (iflag_coupl==4) THEN
3158
3159	! Dans le cas iflag_coupl==4, on prend la somme des convertures
3160	! convectives et lsc dans la partie des thermiques
3161	! Le controle par iflag_coupl est peut etre provisoire.
3162	DO k=1,klev
3163	DO i=1,klon
3164	IF (ptconv(i,k).AND.ptconvth(i,k)) THEN
3165	cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
3166	cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
3167	ELSE IF (ptconv(i,k)) THEN
3168	cldfra(i,k)=rnebcon(i,k)
3169	cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
3170	ENDIF
3171	ENDDO
3172	ENDDO
3173
3174	ELSE IF (iflag_coupl==5) THEN
3175	DO k=1,klev
3176	DO i=1,klon
3177	cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
3178	cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
3179	ENDDO
3180	ENDDO
3181
3182	ELSE
3183
3184	! Si on est sur un point touche par la convection
3185	! profonde et pas par les thermiques, on prend la
3186	! couverture nuageuse et l'eau nuageuse de la convection
3187	! profonde.
3188
3189	!IM/FH: 2011/02/23
3190	! definition des points sur lesquels ls thermiques sont actifs
3191
3192	DO k=1,klev
3193	DO i=1,klon
3194	IF (ptconv(i,k).AND. .NOT.ptconvth(i,k)) THEN
3195	cldfra(i,k)=rnebcon(i,k)
3196	cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
3197	ENDIF
3198	ENDDO
3199	ENDDO
3200
3201	ENDIF
3202
3203	ELSE
3204
3205	! Ancienne version
3206	cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
3207	cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
3208	ENDIF
3209
3210	ENDIF
3211
3212	! plulsc(:)=0.
3213	! do k=1,klev,-1
3214	! do i=1,klon
3215	! zzz=prfl(:,k)+psfl(:,k)
3216	! if (.not.ptconvth.zzz.gt.0.)
3217	! enddo prfl, psfl,
3218	! enddo
3219	!
3220	! 2. NUAGES STARTIFORMES
3221	!
3222	IF (ok_stratus) THEN
3223	CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
3224	DO k = 1, klev
3225	DO i = 1, klon
3226	IF (diafra(i,k).GT.cldfra(i,k)) THEN
3227	cldliq(i,k) = dialiq(i,k)
3228	cldfra(i,k) = diafra(i,k)
3229	ENDIF
3230	ENDDO
3231	ENDDO
3232	ENDIF
3233	!
3234	! Precipitation totale
3235	!
3236	DO i = 1, klon
3237	rain_fall(i) = rain_con(i) + rain_lsc(i)
3238	snow_fall(i) = snow_con(i) + snow_lsc(i)
3239	ENDDO
3240	!
3241	! Calculer l'humidite relative pour diagnostique
3242	!
3243	DO k = 1, klev
3244	DO i = 1, klon
3245	zx_t = t_seri(i,k)
3246	IF (thermcep) THEN
3247	!! if (iflag_ice_thermo.eq.0) then !jyg
3248	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
3249	!! else !jyg
3250	!! zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) !jyg
3251	!! endif !jyg
3252	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
3253	zx_qs = MIN(0.5,zx_qs)
3254	zcor = 1./(1.-retv*zx_qs)
3255	zx_qs = zx_qs*zcor
3256	ELSE
3257	!! IF (zx_t.LT.t_coup) THEN !jyg
3258	IF (zx_t.LT.rtt) THEN !jyg
3259	zx_qs = qsats(zx_t)/pplay(i,k)
3260	ELSE
3261	zx_qs = qsatl(zx_t)/pplay(i,k)
3262	ENDIF
3263	ENDIF
3264	zx_rh(i,k) = q_seri(i,k)/zx_qs
3265	zqsat(i,k)=zx_qs
3266	ENDDO
3267	ENDDO
3268
3269	!IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle
3270	! equivalente a 2m (tpote) pour diagnostique
3271	!
3272	DO i = 1, klon
3273	tpot(i)=zt2m(i)(100000./paprs(i,1))*RKAPPA
3274	IF (thermcep) THEN
3275	IF(zt2m(i).LT.RTT) then
3276	Lheat=RLSTT
3277	ELSE
3278	Lheat=RLVTT
3279	ENDIF
3280	ELSE
3281	IF (zt2m(i).LT.RTT) THEN
3282	Lheat=RLSTT
3283	ELSE
3284	Lheat=RLVTT
3285	ENDIF
3286	ENDIF
3287	tpote(i) = tpot(i)* &
3288	EXP((Lheat qsat2m(i))/(RCPDzt2m(i)))
3289	ENDDO
3290
3291	IF (type_trac == 'inca') THEN
3292	#ifdef INCA
3293	CALL VTe(VTphysiq)
3294	CALL VTb(VTinca)
3295	calday = REAL(days_elapsed + 1) + jH_cur
3296
3297	CALL chemtime(itap+itau_phy-1, date0, dtime, itap)
3298	IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN
3299	CALL AEROSOL_METEO_CALC( &
3300	calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, &
3301	prfl,psfl,pctsrf,cell_area, &
3302	latitude_deg,longitude_deg,u10m,v10m)
3303	ENDIF
3304
3305	zxsnow_dummy(:) = 0.0
3306
3307	CALL chemhook_begin (calday, &
3308	days_elapsed+1, &
3309	jH_cur, &
3310	pctsrf(1,1), &
3311	latitude_deg, &
3312	longitude_deg, &
3313	cell_area, &
3314	paprs, &
3315	pplay, &
3316	coefh(1:klon,1:klev,is_ave), &
3317	pphi, &
3318	t_seri, &
3319	u, &
3320	v, &
3321	wo(:, :, 1), &
3322	q_seri, &
3323	zxtsol, &
3324	zxsnow_dummy, &
3325	solsw, &
3326	albsol1, &
3327	rain_fall, &
3328	snow_fall, &
3329	itop_con, &
3330	ibas_con, &
3331	cldfra, &
3332	nbp_lon, &
3333	nbp_lat-1, &
3334	tr_seri, &
3335	ftsol, &
3336	paprs, &
3337	cdragh, &
3338	cdragm, &
3339	pctsrf, &
3340	pdtphys, &
3341	itap)
3342
3343	CALL VTe(VTinca)
3344	CALL VTb(VTphysiq)
3345	#endif
3346	ENDIF !type_trac = inca
3347
3348
3349	!
3350	! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
3351	!
3352	IF (MOD(itaprad,radpas).EQ.0) THEN
3353
3354	!
3355	!jq - introduce the aerosol direct and first indirect radiative forcings
3356	!jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
3357	IF (flag_aerosol .GT. 0) THEN
3358	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
3359	IF (.NOT. aerosol_couple) THEN
3360	!
3361	CALL readaerosol_optic( &
3362	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
3363	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
3364	mass_solu_aero, mass_solu_aero_pi, &
3365	tau_aero, piz_aero, cg_aero, &
3366	tausum_aero, tau3d_aero)
3367	ENDIF
3368	ELSE ! RRTM radiation
3369	IF (aerosol_couple .AND. config_inca == 'aero' ) THEN
3370	abort_message='config_inca=aero et rrtm=1 impossible'
3371	CALL abort_physic(modname,abort_message,1)
3372	ELSE
3373	!
3374	#ifdef CPP_RRTM
3375	IF (NSW.EQ.6) THEN
3376	!--new aerosol properties SW and LW
3377	!
3378	#ifdef CPP_Dust
3379	!--SPL aerosol model
3380	CALL splaerosol_optic_rrtm( ok_alw, pplay, paprs, t_seri, rhcl, &
3381	tr_seri, mass_solu_aero, mass_solu_aero_pi, &
3382	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
3383	tausum_aero, tau3d_aero)
3384	#else
3385	!--climatologies or INCA aerosols
3386	CALL readaerosol_optic_rrtm( debut, aerosol_couple, ok_alw, &
3387	new_aod, flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, &
3388	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
3389	tr_seri, mass_solu_aero, mass_solu_aero_pi, &
3390	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
3391	tausum_aero, drytausum_aero, tau3d_aero)
3392	#endif
3393	!
3394	ELSE IF (NSW.EQ.2) THEN
3395	!--for now we use the old aerosol properties
3396	!
3397	CALL readaerosol_optic( &
3398	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
3399	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
3400	mass_solu_aero, mass_solu_aero_pi, &
3401	tau_aero, piz_aero, cg_aero, &
3402	tausum_aero, tau3d_aero)
3403	!
3404	!--natural aerosols
3405	tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:)
3406	piz_aero_sw_rrtm(:,:,1,:)=piz_aero(:,:,3,:)
3407	cg_aero_sw_rrtm (:,:,1,:)=cg_aero (:,:,3,:)
3408	!--all aerosols
3409	tau_aero_sw_rrtm(:,:,2,:)=tau_aero(:,:,2,:)
3410	piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:)
3411	cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:)
3412	!
3413	!--no LW optics
3414	tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
3415	!
3416	ELSE
3417	abort_message='Only NSW=2 or 6 are possible with ' &
3418	// 'aerosols and iflag_rrtm=1'
3419	CALL abort_physic(modname,abort_message,1)
3420	ENDIF
3421	#else
3422	abort_message='You should compile with -rrtm if running ' &
3423	// 'with iflag_rrtm=1'
3424	CALL abort_physic(modname,abort_message,1)
3425	#endif
3426	!
3427	ENDIF
3428	ENDIF
3429	ELSE !--flag_aerosol = 0
3430	tausum_aero(:,:,:) = 0.
3431	drytausum_aero(:,:) = 0.
3432	mass_solu_aero(:,:) = 0.
3433	mass_solu_aero_pi(:,:) = 0.
3434	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
3435	tau_aero(:,:,:,:) = 1.e-15
3436	piz_aero(:,:,:,:) = 1.
3437	cg_aero(:,:,:,:) = 0.
3438	ELSE
3439	tau_aero_sw_rrtm(:,:,:,:) = 1.e-15
3440	tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
3441	piz_aero_sw_rrtm(:,:,:,:) = 1.0
3442	cg_aero_sw_rrtm(:,:,:,:) = 0.0
3443	ENDIF
3444	ENDIF
3445	!
3446	!--STRAT AEROSOL
3447	!--updates tausum_aero,tau_aero,piz_aero,cg_aero
3448	IF (flag_aerosol_strat.GT.0) THEN
3449	IF (prt_level .GE.10) THEN
3450	PRINT *,'appel a readaerosolstrat', mth_cur
3451	ENDIF
3452	IF (iflag_rrtm.EQ.0) THEN
3453	IF (flag_aerosol_strat.EQ.1) THEN
3454	CALL readaerosolstrato(debut)
3455	ELSE
3456	abort_message='flag_aerosol_strat must equal 1 for rrtm=0'
3457	CALL abort_physic(modname,abort_message,1)
3458	ENDIF
3459	ELSE
3460	#ifdef CPP_RRTM
3461	#ifndef CPP_StratAer
3462	!--prescribed strat aerosols
3463	!--only in the case of non-interactive strat aerosols
3464	IF (flag_aerosol_strat.EQ.1) THEN
3465	CALL readaerosolstrato1_rrtm(debut)
3466	ELSEIF (flag_aerosol_strat.EQ.2) THEN
3467	CALL stratosphere_mask(t_seri, pplay, latitude_deg)
3468	CALL readaerosolstrato2_rrtm(debut)
3469	ELSE
3470	abort_message='flag_aerosol_strat must equal 1 or 2 for rrtm=1'
3471	CALL abort_physic(modname,abort_message,1)
3472	ENDIF
3473	#endif
3474	#else
3475	abort_message='You should compile with -rrtm if running ' &
3476	// 'with iflag_rrtm=1'
3477	CALL abort_physic(modname,abort_message,1)
3478	#endif
3479	ENDIF
3480	ENDIF
3481	!
3482	#ifdef CPP_RRTM
3483	#ifdef CPP_StratAer
3484	!--compute stratospheric mask
3485	CALL stratosphere_mask(t_seri, pplay, latitude_deg)
3486	!--interactive strat aerosols
3487	CALL calcaerosolstrato_rrtm(pplay,t_seri,paprs,debut)
3488	#endif
3489	#endif
3490	!--fin STRAT AEROSOL
3491	!
3492
3493	! Calculer les parametres optiques des nuages et quelques
3494	! parametres pour diagnostiques:
3495	!
3496	IF (aerosol_couple.AND.config_inca=='aero') THEN
3497	mass_solu_aero(:,:) = ccm(:,:,1)
3498	mass_solu_aero_pi(:,:) = ccm(:,:,2)
3499	ENDIF
3500
3501	IF (ok_newmicro) then
3502	IF (iflag_rrtm.NE.0) THEN
3503	#ifdef CPP_RRTM
3504	IF (ok_cdnc.AND.NRADLP.NE.3) THEN
3505	abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 ' &
3506	// 'pour ok_cdnc'
3507	CALL abort_physic(modname,abort_message,1)
3508	ENDIF
3509	#else
3510
3511	abort_message='You should compile with -rrtm if running with '//'iflag_rrtm=1'
3512	CALL abort_physic(modname,abort_message,1)
3513	#endif
3514	ENDIF
3515	CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, &
3516	paprs, pplay, t_seri, cldliq, cldfra, &
3517	cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, &
3518	flwp, fiwp, flwc, fiwc, &
3519	mass_solu_aero, mass_solu_aero_pi, &
3520	cldtaupi, re, fl, ref_liq, ref_ice, &
3521	ref_liq_pi, ref_ice_pi)
3522	ELSE
3523	CALL nuage (paprs, pplay, &
3524	t_seri, cldliq, cldfra, cldtau, cldemi, &
3525	cldh, cldl, cldm, cldt, cldq, &
3526	ok_aie, &
3527	mass_solu_aero, mass_solu_aero_pi, &
3528	bl95_b0, bl95_b1, &
3529	cldtaupi, re, fl)
3530	ENDIF
3531	!
3532	!IM betaCRF
3533	!
3534	cldtaurad = cldtau
3535	cldtaupirad = cldtaupi
3536	cldemirad = cldemi
3537	cldfrarad = cldfra
3538
3539	!
3540	IF (lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. &
3541	lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN
3542	!
3543	! global
3544	!
3545	DO k=1, klev
3546	DO i=1, klon
3547	IF (pplay(i,k).GE.pfree) THEN
3548	beta(i,k) = beta_pbl
3549	ELSE
3550	beta(i,k) = beta_free
3551	ENDIF
3552	IF (mskocean_beta) THEN
3553	beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
3554	ENDIF
3555	cldtaurad(i,k) = cldtau(i,k) * beta(i,k)
3556	cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
3557	cldemirad(i,k) = cldemi(i,k) * beta(i,k)
3558	cldfrarad(i,k) = cldfra(i,k) * beta(i,k)
3559	ENDDO
3560	ENDDO
3561	!
3562	ELSE
3563	!
3564	! regional
3565	!
3566	DO k=1, klev
3567	DO i=1,klon
3568	!
3569	IF (longitude_deg(i).ge.lon1_beta.AND. &
3570	longitude_deg(i).le.lon2_beta.AND. &
3571	latitude_deg(i).le.lat1_beta.AND. &
3572	latitude_deg(i).ge.lat2_beta) THEN
3573	IF (pplay(i,k).GE.pfree) THEN
3574	beta(i,k) = beta_pbl
3575	ELSE
3576	beta(i,k) = beta_free
3577	ENDIF
3578	IF (mskocean_beta) THEN
3579	beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
3580	ENDIF
3581	cldtaurad(i,k) = cldtau(i,k) * beta(i,k)
3582	cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
3583	cldemirad(i,k) = cldemi(i,k) * beta(i,k)
3584	cldfrarad(i,k) = cldfra(i,k) * beta(i,k)
3585	ENDIF
3586	!
3587	ENDDO
3588	ENDDO
3589	!
3590	ENDIF
3591
3592	!lecture de la chlorophylle pour le nouvel albedo de Sunghye Baek
3593	IF (ok_chlorophyll) THEN
3594	print*,"-- reading chlorophyll"
3595	CALL readchlorophyll(debut)
3596	ENDIF
3597
3598	!--if ok_suntime_rrtm we use ancillay data for RSUN
3599	!--previous values are therefore overwritten
3600	!--this is needed for CMIP6 runs
3601	!--and only possible for new radiation scheme
3602	IF (iflag_rrtm.EQ.1.AND.ok_suntime_rrtm) THEN
3603	#ifdef CPP_RRTM
3604	CALL read_rsun_rrtm(debut)
3605	#endif
3606	ENDIF
3607
3608	IF (mydebug) THEN
3609	CALL writefield_phy('u_seri',u_seri,nbp_lev)
3610	CALL writefield_phy('v_seri',v_seri,nbp_lev)
3611	CALL writefield_phy('t_seri',t_seri,nbp_lev)
3612	CALL writefield_phy('q_seri',q_seri,nbp_lev)
3613	ENDIF
3614
3615	!
3616	!sonia : If Iflag_radia >=2, pertubation of some variables
3617	!input to radiation (DICE)
3618	!
3619	IF (iflag_radia .ge. 2) THEN
3620	zsav_tsol (:) = zxtsol(:)
3621	CALL perturb_radlwsw(zxtsol,iflag_radia)
3622	ENDIF
3623
3624	IF (aerosol_couple.AND.config_inca=='aero') THEN
3625	#ifdef INCA
3626	CALL radlwsw_inca &
3627	(kdlon,kflev,dist, rmu0, fract, solaire, &
3628	paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, &
3629	size(wo,3), wo, &
3630	cldfrarad, cldemirad, cldtaurad, &
3631	heat,heat0,cool,cool0,albpla, &
3632	topsw,toplw,solsw,sollw, &
3633	sollwdown, &
3634	topsw0,toplw0,solsw0,sollw0, &
3635	lwdn0, lwdn, lwup0, lwup, &
3636	swdn0, swdn, swup0, swup, &
3637	ok_ade, ok_aie, &
3638	tau_aero, piz_aero, cg_aero, &
3639	topswad_aero, solswad_aero, &
3640	topswad0_aero, solswad0_aero, &
3641	topsw_aero, topsw0_aero, &
3642	solsw_aero, solsw0_aero, &
3643	cldtaupirad, &
3644	topswai_aero, solswai_aero)
3645	#endif
3646	ELSE
3647	!
3648	!IM calcul radiatif pour le cas actuel
3649	!
3650	RCO2 = RCO2_act
3651	RCH4 = RCH4_act
3652	RN2O = RN2O_act
3653	RCFC11 = RCFC11_act
3654	RCFC12 = RCFC12_act
3655	!
3656	IF (prt_level .GE.10) THEN
3657	print *,' ->radlwsw, number 1 '
3658	ENDIF
3659	!
3660	CALL radlwsw &
3661	(dist, rmu0, fract, &
3662	!albedo SB >>>
3663	! paprs, pplay,zxtsol,albsol1, albsol2, &
3664	paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
3665	!albedo SB <<<
3666	t_seri,q_seri,wo, &
3667	cldfrarad, cldemirad, cldtaurad, &
3668	ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
3669	flag_aerosol_strat, &
3670	tau_aero, piz_aero, cg_aero, &
3671	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
3672	! Rajoute par OB pour RRTM
3673	tau_aero_lw_rrtm, &
3674	cldtaupirad,new_aod, &
3675	zqsat, flwc, fiwc, &
3676	ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
3677	heat,heat0,cool,cool0,albpla, &
3678	topsw,toplw,solsw,sollw, &
3679	sollwdown, &
3680	topsw0,toplw0,solsw0,sollw0, &
3681	lwdn0, lwdn, lwup0, lwup, &
3682	swdn0, swdn, swup0, swup, &
3683	topswad_aero, solswad_aero, &
3684	topswai_aero, solswai_aero, &
3685	topswad0_aero, solswad0_aero, &
3686	topsw_aero, topsw0_aero, &
3687	solsw_aero, solsw0_aero, &
3688	topswcf_aero, solswcf_aero, &
3689	!-C. Kleinschmitt for LW diagnostics
3690	toplwad_aero, sollwad_aero,&
3691	toplwai_aero, sollwai_aero, &
3692	toplwad0_aero, sollwad0_aero,&
3693	!-end
3694	ZLWFT0_i, ZFLDN0, ZFLUP0, &
3695	ZSWFT0_i, ZFSDN0, ZFSUP0)
3696
3697	#ifndef CPP_XIOS
3698	!--OB 30/05/2016 modified 21/10/2016
3699	!--here we return swaero_diag and dryaod_diag to FALSE
3700	!--and histdef will switch it back to TRUE if necessary
3701	!--this is necessary to get the right swaero at first step
3702	!--but only in the case of no XIOS as XIOS is covered elsewhere
3703	IF (debut) swaero_diag = .FALSE.
3704	IF (debut) dryaod_diag = .FALSE.
3705	#endif
3706	!
3707	!IM 2eme calcul radiatif pour le cas perturbe ou au moins un
3708	!IM des taux doit etre different du taux actuel
3709	!IM Par defaut on a les taux perturbes egaux aux taux actuels
3710	!
3711	IF (ok_4xCO2atm) THEN
3712	IF (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. &
3713	RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. &
3714	RCFC12_per.NE.RCFC12_act) THEN
3715	!
3716	RCO2 = RCO2_per
3717	RCH4 = RCH4_per
3718	RN2O = RN2O_per
3719	RCFC11 = RCFC11_per
3720	RCFC12 = RCFC12_per
3721	!
3722	IF (prt_level .GE.10) THEN
3723	print *,' ->radlwsw, number 2 '
3724	ENDIF
3725	!
3726	CALL radlwsw &
3727	(dist, rmu0, fract, &
3728	!albedo SB >>>
3729	! paprs, pplay,zxtsol,albsol1, albsol2, &
3730	paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
3731	!albedo SB <<<
3732	t_seri,q_seri,wo, &
3733	cldfrarad, cldemirad, cldtaurad, &
3734	ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
3735	flag_aerosol_strat, &
3736	tau_aero, piz_aero, cg_aero, &
3737	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
3738	! Rajoute par OB pour RRTM
3739	tau_aero_lw_rrtm, &
3740	cldtaupi,new_aod, &
3741	zqsat, flwc, fiwc, &
3742	ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
3743	heatp,heat0p,coolp,cool0p,albplap, &
3744	topswp,toplwp,solswp,sollwp, &
3745	sollwdownp, &
3746	topsw0p,toplw0p,solsw0p,sollw0p, &
3747	lwdn0p, lwdnp, lwup0p, lwupp, &
3748	swdn0p, swdnp, swup0p, swupp, &
3749	topswad_aerop, solswad_aerop, &
3750	topswai_aerop, solswai_aerop, &
3751	topswad0_aerop, solswad0_aerop, &
3752	topsw_aerop, topsw0_aerop, &
3753	solsw_aerop, solsw0_aerop, &
3754	topswcf_aerop, solswcf_aerop, &
3755	!-C. Kleinschmitt for LW diagnostics
3756	toplwad_aerop, sollwad_aerop,&
3757	toplwai_aerop, sollwai_aerop, &
3758	toplwad0_aerop, sollwad0_aerop,&
3759	!-end
3760	ZLWFT0_i, ZFLDN0, ZFLUP0, &
3761	ZSWFT0_i, ZFSDN0, ZFSUP0)
3762	endif
3763	endif
3764	!
3765	ENDIF ! aerosol_couple
3766	itaprad = 0
3767	!
3768	! If Iflag_radia >=2, reset pertubed variables
3769	!
3770	IF (iflag_radia .ge. 2) THEN
3771	zxtsol(:) = zsav_tsol (:)
3772	ENDIF
3773	ENDIF ! MOD(itaprad,radpas)
3774	itaprad = itaprad + 1
3775
3776	IF (iflag_radia.eq.0) THEN
3777	IF (prt_level.ge.9) THEN
3778	PRINT *,'--------------------------------------------------'
3779	PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas'
3780	PRINT *,'>>>> heat et cool mis a zero '
3781	PRINT *,'--------------------------------------------------'
3782	ENDIF
3783	heat=0.
3784	cool=0.
3785	sollw=0. ! MPL 01032011
3786	solsw=0.
3787	radsol=0.
3788	swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars
3789	swup0=0.
3790	lwup=0.
3791	lwup0=0.
3792	lwdn=0.
3793	lwdn0=0.
3794	ENDIF
3795
3796	!
3797	! Calculer radsol a l'exterieur de radlwsw
3798	! pour prendre en compte le cycle diurne
3799	! recode par Olivier Boucher en sept 2015
3800	!
3801	radsol=solsw*swradcorr+sollw
3802
3803	IF (ok_4xCO2atm) THEN
3804	radsolp=solswp*swradcorr+sollwp
3805	ENDIF
3806
3807	!
3808	! Ajouter la tendance des rayonnements (tous les pas)
3809	! avec une correction pour le cycle diurne dans le SW
3810	!
3811
3812	DO k=1, klev
3813	d_t_swr(:,k)=swradcorr(:)heat(:,k)dtime/RDAY
3814	d_t_sw0(:,k)=swradcorr(:)heat0(:,k)dtime/RDAY
3815	d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY
3816	d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY
3817	ENDDO
3818
3819	CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy,flag_inhib_tend,itap,0)
3820	call prt_enerbil('SW',itap)
3821	CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy,flag_inhib_tend,itap,0)
3822	call prt_enerbil('LW',itap)
3823
3824	!
3825	IF (mydebug) THEN
3826	CALL writefield_phy('u_seri',u_seri,nbp_lev)
3827	CALL writefield_phy('v_seri',v_seri,nbp_lev)
3828	CALL writefield_phy('t_seri',t_seri,nbp_lev)
3829	CALL writefield_phy('q_seri',q_seri,nbp_lev)
3830	ENDIF
3831
3832	! Calculer l'hydrologie de la surface
3833	!
3834	! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
3835	! . agesno, ftsol,fqsurf,fsnow, ruis)
3836	!
3837
3838	!
3839	! Calculer le bilan du sol et la derive de temperature (couplage)
3840	!
3841	DO i = 1, klon
3842	! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
3843	! a la demande de JLD
3844	bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
3845	ENDDO
3846	!
3847	!moddeblott(jan95)
3848	! Appeler le programme de parametrisation de l'orographie
3849	! a l'echelle sous-maille:
3850	!
3851	IF (prt_level .GE.10) THEN
3852	print *,' call orography ? ', ok_orodr
3853	ENDIF
3854	!
3855	IF (ok_orodr) THEN
3856	!
3857	! selection des points pour lesquels le shema est actif:
3858	igwd=0
3859	DO i=1,klon
3860	itest(i)=0
3861	! IF ((zstd(i).gt.10.0)) THEN
3862	IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
3863	itest(i)=1
3864	igwd=igwd+1
3865	idx(igwd)=i
3866	ENDIF
3867	ENDDO
3868	! igwdim=MAX(1,igwd)
3869	!
3870	IF (ok_strato) THEN
3871
3872	CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, &
3873	zmea,zstd, zsig, zgam, zthe,zpic,zval, &
3874	igwd,idx,itest, &
3875	t_seri, u_seri, v_seri, &
3876	zulow, zvlow, zustrdr, zvstrdr, &
3877	d_t_oro, d_u_oro, d_v_oro)
3878
3879	ELSE
3880	CALL drag_noro(klon,klev,dtime,paprs,pplay, &
3881	zmea,zstd, zsig, zgam, zthe,zpic,zval, &
3882	igwd,idx,itest, &
3883	t_seri, u_seri, v_seri, &
3884	zulow, zvlow, zustrdr, zvstrdr, &
3885	d_t_oro, d_u_oro, d_v_oro)
3886	ENDIF
3887	!
3888	! ajout des tendances
3889	!-----------------------------------------------------------------------
3890	! ajout des tendances de la trainee de l'orographie
3891	CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro', &
3892	abortphy,flag_inhib_tend,itap,0)
3893	call prt_enerbil('oro',itap)
3894	!----------------------------------------------------------------------
3895	!
3896	ENDIF ! fin de test sur ok_orodr
3897	!
3898	IF (mydebug) THEN
3899	CALL writefield_phy('u_seri',u_seri,nbp_lev)
3900	CALL writefield_phy('v_seri',v_seri,nbp_lev)
3901	CALL writefield_phy('t_seri',t_seri,nbp_lev)
3902	CALL writefield_phy('q_seri',q_seri,nbp_lev)
3903	ENDIF
3904
3905	IF (ok_orolf) THEN
3906	!
3907	! selection des points pour lesquels le shema est actif:
3908	igwd=0
3909	DO i=1,klon
3910	itest(i)=0
3911	IF ((zpic(i)-zmea(i)).GT.100.) THEN
3912	itest(i)=1
3913	igwd=igwd+1
3914	idx(igwd)=i
3915	ENDIF
3916	ENDDO
3917	! igwdim=MAX(1,igwd)
3918	!
3919	IF (ok_strato) THEN
3920
3921	CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, &
3922	latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, &
3923	igwd,idx,itest, &
3924	t_seri, u_seri, v_seri, &
3925	zulow, zvlow, zustrli, zvstrli, &
3926	d_t_lif, d_u_lif, d_v_lif )
3927
3928	ELSE
3929	CALL lift_noro(klon,klev,dtime,paprs,pplay, &
3930	latitude_deg,zmea,zstd,zpic, &
3931	itest, &
3932	t_seri, u_seri, v_seri, &
3933	zulow, zvlow, zustrli, zvstrli, &
3934	d_t_lif, d_u_lif, d_v_lif)
3935	ENDIF
3936
3937	! ajout des tendances de la portance de l'orographie
3938	CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, &
3939	'lif', abortphy,flag_inhib_tend,itap,0)
3940	call prt_enerbil('lif',itap)
3941	ENDIF ! fin de test sur ok_orolf
3942
3943	IF (ok_hines) then
3944	! HINES GWD PARAMETRIZATION
3945	east_gwstress=0.
3946	west_gwstress=0.
3947	du_gwd_hines=0.
3948	dv_gwd_hines=0.
3949	CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, &
3950	u_seri, v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, &
3951	du_gwd_hines, dv_gwd_hines)
3952	zustr_gwd_hines=0.
3953	zvstr_gwd_hines=0.
3954	DO k = 1, klev
3955	zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime &
3956	* (paprs(:, k)-paprs(:, k+1))/rg
3957	zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime &
3958	* (paprs(:, k)-paprs(:, k+1))/rg
3959	ENDDO
3960
3961	d_t_hin(:, :)=0.
3962	CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, &
3963	dqi0, paprs, 'hin', abortphy,flag_inhib_tend,itap,0)
3964	call prt_enerbil('hin',itap)
3965	ENDIF
3966
3967	IF (.not. ok_hines .and. ok_gwd_rando) then
3968	CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, &
3969	v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, &
3970	dv_gwd_front, east_gwstress, west_gwstress)
3971	zustr_gwd_front=0.
3972	zvstr_gwd_front=0.
3973	DO k = 1, klev
3974	zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime &
3975	* (paprs(:, k)-paprs(:, k+1))/rg
3976	zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime &
3977	* (paprs(:, k)-paprs(:, k+1))/rg
3978	ENDDO
3979
3980	CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, &
3981	paprs, 'front_gwd_rando', abortphy,flag_inhib_tend,itap,0)
3982	call prt_enerbil('front_gwd_rando',itap)
3983	ENDIF
3984
3985	IF (ok_gwd_rando) THEN
3986	CALL FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, &
3987	rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, &
3988	du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress)
3989	CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, &
3990	paprs, 'flott_gwd_rando', abortphy,flag_inhib_tend,itap,0)
3991	call prt_enerbil('flott_gwd_rando',itap)
3992	zustr_gwd_rando=0.
3993	zvstr_gwd_rando=0.
3994	DO k = 1, klev
3995	zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime &
3996	* (paprs(:, k)-paprs(:, k+1))/rg
3997	zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime &
3998	* (paprs(:, k)-paprs(:, k+1))/rg
3999	ENDDO
4000	ENDIF
4001
4002	! STRESS NECESSAIRES: TOUTE LA PHYSIQUE
4003
4004	IF (mydebug) THEN
4005	CALL writefield_phy('u_seri',u_seri,nbp_lev)
4006	CALL writefield_phy('v_seri',v_seri,nbp_lev)
4007	CALL writefield_phy('t_seri',t_seri,nbp_lev)
4008	CALL writefield_phy('q_seri',q_seri,nbp_lev)
4009	ENDIF
4010
4011	DO i = 1, klon
4012	zustrph(i)=0.
4013	zvstrph(i)=0.
4014	ENDDO
4015	DO k = 1, klev
4016	DO i = 1, klon
4017	zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* &
4018	(paprs(i,k)-paprs(i,k+1))/rg
4019	zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* &
4020	(paprs(i,k)-paprs(i,k+1))/rg
4021	ENDDO
4022	ENDDO
4023	!
4024	!IM calcul composantes axiales du moment angulaire et couple des montagnes
4025	!
4026	IF (is_sequential .and. ok_orodr) THEN
4027	CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, &
4028	ra,rg,romega, &
4029	latitude_deg,longitude_deg,pphis, &
4030	zustrdr,zustrli,zustrph, &
4031	zvstrdr,zvstrli,zvstrph, &
4032	paprs,u,v, &
4033	aam, torsfc)
4034	ENDIF
4035	!IM cf. FLott END
4036	!DC Calcul de la tendance due au methane
4037	IF(ok_qch4) THEN
4038	CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay)
4039	! ajout de la tendance d'humidite due au methane
4040	d_q_ch4_dtime(:,:) = d_q_ch4(:,:)*dtime
4041	CALL add_phys_tend(du0, dv0, dt0, d_q_ch4_dtime, dql0, dqi0, paprs, &
4042	'q_ch4', abortphy,flag_inhib_tend,itap,0)
4043	d_q_ch4(:,:) = d_q_ch4_dtime(:,:)/dtime
4044	ENDIF
4045	!
4046	!
4047	!====================================================================
4048	! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..)
4049	!====================================================================
4050	! Abderrahmane 24.08.09
4051
4052	IF (ok_cosp) THEN
4053	! adeclarer
4054	#ifdef CPP_COSP
4055	IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN
4056
4057	IF (prt_level .GE.10) THEN
4058	print*,'freq_cosp',freq_cosp
4059	ENDIF
4060	mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse
4061	! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=',
4062	! s ref_liq,ref_ice
4063	CALL phys_cosp(itap,dtime,freq_cosp, &
4064	ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
4065	ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, &
4066	klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
4067	JrNt,ref_liq,ref_ice, &
4068	pctsrf(:,is_ter)+pctsrf(:,is_lic), &
4069	zu10m,zv10m,pphis, &
4070	zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
4071	qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
4072	prfl(:,1:klev),psfl(:,1:klev), &
4073	pmflxr(:,1:klev),pmflxs(:,1:klev), &
4074	mr_ozone,cldtau, cldemi)
4075
4076	! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol,
4077	! L cfaddbze,clcalipso2,dbze,cltlidarradar,
4078	! M clMISR,
4079	! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp,
4080	! I tauisccp,albisccp,meantbisccp,meantbclrisccp)
4081
4082	ENDIF
4083
4084	#endif
4085	ENDIF !ok_cosp
4086
4087
4088	! Marine
4089
4090	IF (ok_airs) then
4091
4092	IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/dtime)).EQ.0) THEN
4093	write(,) 'je vais appeler simu_airs, ok_airs, freq_airs=', ok_airs, freq_airs
4094	CALL simu_airs(itap,rneb, t_seri, cldemi, fiwc, ref_ice, pphi, pplay, paprs,&
4095	& map_prop_hc,map_prop_hist,&
4096	& map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,&
4097	& map_emis_Cb,map_pcld_Cb,map_tcld_Cb,&
4098	& map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,&
4099	& map_emis_Anv,map_pcld_Anv,map_tcld_Anv,&
4100	& map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,&
4101	& map_ntot,map_hc,map_hist,&
4102	& map_Cb,map_ThCi,map_Anv,&
4103	& alt_tropo )
4104	ENDIF
4105
4106	ENDIF ! ok_airs
4107
4108
4109	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4110	!AA
4111	!AA Installation de l'interface online-offline pour traceurs
4112	!AA
4113	!====================================================================
4114	! Calcul des tendances traceurs
4115	!====================================================================
4116	!
4117
4118	IF (type_trac=='repr') THEN
4119	sh_in(:,:) = q_seri(:,:)
4120	ELSE
4121	sh_in(:,:) = qx(:,:,ivap)
4122	ch_in(:,:) = qx(:,:,iliq)
4123	ENDIF
4124
4125	#ifdef CPP_Dust
4126	CALL phytracr_spl ( debut,lafin , jD_cur,jH_cur,iflag_con, & ! I
4127	pdtphys,ftsol, & ! I
4128	t,q_seri,paprs,pplay,RHcl, & ! I
4129	pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, & ! I
4130	coefh(1:klon,1:klev,is_ave), cdragh, cdragm, u1, v1, & ! I
4131	u_seri, v_seri, latitude_deg, longitude_deg, &
4132	pphis,pctsrf,pmflxr,pmflxs,prfl,psfl, & ! I
4133	da,phi,phi2,d1a,dam,mp,ep,sigd,sij,clw,elij, & ! I
4134	epmlmMm,eplaMm,upwd,dnwd,itop_con,ibas_con, & ! I
4135	ev,wdtrainA, wdtrainM,wght_cvfd, & ! I
4136	fm_therm, entr_therm, rneb, & ! I
4137	beta_prec_fisrt,beta_prec, & !I
4138	zu10m,zv10m,wstar,ale_bl,ale_wake, & ! I
4139	d_tr_dyn,tr_seri)
4140
4141	#else
4142
4143	CALL phytrac ( &
4144	itap, days_elapsed+1, jH_cur, debut, &
4145	lafin, dtime, u, v, t, &
4146	paprs, pplay, pmfu, pmfd, &
4147	pen_u, pde_u, pen_d, pde_d, &
4148	cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, &
4149	u1, v1, ftsol, pctsrf, &
4150	zustar, zu10m, zv10m, &
4151	wstar(:,is_ave), ale_bl, ale_wake, &
4152	latitude_deg, longitude_deg, &
4153	frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, &
4154	presnivs, pphis, pphi, albsol1, &
4155	sh_in, ch_in, rhcl, cldfra, rneb, &
4156	diafra, cldliq, itop_con, ibas_con, &
4157	pmflxr, pmflxs, prfl, psfl, &
4158	da, phi, mp, upwd, &
4159	phi2, d1a, dam, sij, wght_cvfd, & !<<RomP+RL
4160	wdtrainA, wdtrainM, sigd, clw,elij, & !<<RomP
4161	ev, ep, epmlmMm, eplaMm, & !<<RomP
4162	dnwd, aerosol_couple, flxmass_w, &
4163	tau_aero, piz_aero, cg_aero, ccm, &
4164	rfname, &
4165	d_tr_dyn, & !<<RomP
4166	tr_seri)
4167	#endif
4168
4169	IF (offline) THEN
4170
4171	IF (prt_level.ge.9) &
4172	print*,'Attention on met a 0 les thermiques pour phystoke'
4173	CALL phystokenc ( &
4174	nlon,klev,pdtphys,longitude_deg,latitude_deg, &
4175	t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
4176	fm_therm,entr_therm, &
4177	cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, &
4178	frac_impa, frac_nucl, &
4179	pphis,cell_area,dtime,itap, &
4180	qx(:,:,ivap),da,phi,mp,upwd,dnwd)
4181
4182
4183	ENDIF
4184
4185	!
4186	! Calculer le transport de l'eau et de l'energie (diagnostique)
4187	!
4188	CALL transp (paprs,zxtsol, &
4189	t_seri, q_seri, u_seri, v_seri, zphi, &
4190	ve, vq, ue, uq)
4191	!
4192	!IM global posePB BEG
4193	IF(1.EQ.0) THEN
4194	!
4195	CALL transp_lay (paprs,zxtsol, &
4196	t_seri, q_seri, u_seri, v_seri, zphi, &
4197	ve_lay, vq_lay, ue_lay, uq_lay)
4198	!
4199	ENDIF !(1.EQ.0) THEN
4200	!IM global posePB END
4201	! Accumuler les variables a stocker dans les fichiers histoire:
4202	!
4203
4204	!================================================================
4205	! Conversion of kinetic and potential energy into heat, for
4206	! parameterisation of subgrid-scale motions
4207	!================================================================
4208
4209	d_t_ec(:,:)=0.
4210	forall (k=1: nbp_lev) exner(:, k) = (pplay(:, k)/paprs(:,1))**RKAPPA
4211	CALL ener_conserv(klon,klev,pdtphys,u,v,t,qx(:,:,ivap),qx(:,:,iliq),qx(:,:,isol), &
4212	u_seri,v_seri,t_seri,q_seri,ql_seri,qs_seri,pbl_tke(:,:,is_ave)-tke0(:,:), &
4213	zmasse,exner,d_t_ec)
4214	t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:)
4215
4216	!=======================================================================
4217	! SORTIES
4218	!=======================================================================
4219	!
4220	!IM initialisation + calculs divers diag AMIP2
4221	!
4222	include "calcul_divers.h"
4223	!
4224	!IM Interpolation sur les niveaux de pression du NMC
4225	! -------------------------------------------------
4226	#ifdef CPP_XIOS
4227	!$OMP MASTER
4228	!On recupere la valeur de la missing value donnee dans le xml
4229	CALL xios_get_field_attr("t850",default_value=missing_val_omp)
4230	! PRINT *,"ARNAUD value missing ",missing_val_omp
4231	!$OMP END MASTER
4232	!$OMP BARRIER
4233	missing_val=missing_val_omp
4234	#endif
4235	#ifndef CPP_XIOS
4236	missing_val=missing_val_nf90
4237	#endif
4238	!
4239	include "calcul_STDlev.h"
4240	!
4241	! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer
4242	CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp)
4243	!
4244	!cc prw = eau precipitable
4245	! prlw = colonne eau liquide
4246	! prlw = colonne eau solide
4247	prw(:) = 0.
4248	prlw(:) = 0.
4249	prsw(:) = 0.
4250	DO k = 1, klev
4251	prw(:) = prw(:) + q_seri(:,k)*zmasse(:,k)
4252	prlw(:) = prlw(:) + ql_seri(:,k)*zmasse(:,k)
4253	prsw(:) = prsw(:) + qs_seri(:,k)*zmasse(:,k)
4254	ENDDO
4255	!
4256	IF (type_trac == 'inca') THEN
4257	#ifdef INCA
4258	CALL VTe(VTphysiq)
4259	CALL VTb(VTinca)
4260
4261	CALL chemhook_end ( &
4262	dtime, &
4263	pplay, &
4264	t_seri, &
4265	tr_seri, &
4266	nbtr, &
4267	paprs, &
4268	q_seri, &
4269	cell_area, &
4270	pphi, &
4271	pphis, &
4272	zx_rh, &
4273	aps, bps)
4274
4275	CALL VTe(VTinca)
4276	CALL VTb(VTphysiq)
4277	#endif
4278	ENDIF
4279
4280
4281	!
4282	! Convertir les incrementations en tendances
4283	!
4284	IF (prt_level .GE.10) THEN
4285	print *,'Convertir les incrementations en tendances '
4286	ENDIF
4287	!
4288	IF (mydebug) THEN
4289	CALL writefield_phy('u_seri',u_seri,nbp_lev)
4290	CALL writefield_phy('v_seri',v_seri,nbp_lev)
4291	CALL writefield_phy('t_seri',t_seri,nbp_lev)
4292	CALL writefield_phy('q_seri',q_seri,nbp_lev)
4293	ENDIF
4294
4295	DO k = 1, klev
4296	DO i = 1, klon
4297	d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
4298	d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
4299	d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
4300	d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
4301	d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
4302	!CR: on ajoute le contenu en glace
4303	IF (nqo.eq.3) THEN
4304	d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime
4305	ENDIF
4306	ENDDO
4307	ENDDO
4308	!
4309	!CR: nb de traceurs eau: nqo
4310	! IF (nqtot.GE.3) THEN
4311	IF (nqtot.GE.(nqo+1)) THEN
4312	! DO iq = 3, nqtot
4313	DO iq = nqo+1, nqtot
4314	DO k = 1, klev
4315	DO i = 1, klon
4316	! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
4317	d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime
4318	ENDDO
4319	ENDDO
4320	ENDDO
4321	ENDIF
4322	!
4323	!IM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
4324	!IM global posePB include "write_bilKP_ins.h"
4325	!IM global posePB include "write_bilKP_ave.h"
4326	!
4327
4328	!--OB mass fixer
4329	!--profile is corrected to force mass conservation of water
4330	IF (mass_fixer) THEN
4331	qql2(:)=0.0
4332	DO k = 1, klev
4333	qql2(:)=qql2(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k))*zmasse(:,k)
4334	ENDDO
4335	DO i = 1, klon
4336	!--compute ratio of what q+ql should be with conservation to what it is
4337	corrqql=(qql1(i)+(evap(i)-rain_fall(i)-snow_fall(i))*pdtphys)/qql2(i)
4338	DO k = 1, klev
4339	q_seri(i,k) =q_seri(i,k)*corrqql
4340	ql_seri(i,k)=ql_seri(i,k)*corrqql
4341	ENDDO
4342	ENDDO
4343	ENDIF
4344	!--fin mass fixer
4345
4346	! Sauvegarder les valeurs de t et q a la fin de la physique:
4347	!
4348	u_ancien(:,:) = u_seri(:,:)
4349	v_ancien(:,:) = v_seri(:,:)
4350	t_ancien(:,:) = t_seri(:,:)
4351	q_ancien(:,:) = q_seri(:,:)
4352	ql_ancien(:,:) = ql_seri(:,:)
4353	qs_ancien(:,:) = qs_seri(:,:)
4354	CALL water_int(klon,klev,q_ancien,zmasse,prw_ancien)
4355	CALL water_int(klon,klev,ql_ancien,zmasse,prlw_ancien)
4356	CALL water_int(klon,klev,qs_ancien,zmasse,prsw_ancien)
4357	! !! RomP >>>
4358	!CR: nb de traceurs eau: nqo
4359	IF (nqtot.GT.nqo) THEN
4360	DO iq = nqo+1, nqtot
4361	tr_ancien(:,:,iq-nqo) = tr_seri(:,:,iq-nqo)
4362	ENDDO
4363	ENDIF
4364	! !! RomP <<<
4365	!==========================================================================
4366	! Sorties des tendances pour un point particulier
4367	! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier
4368	! pour le debug
4369	! La valeur de igout est attribuee plus haut dans le programme
4370	!==========================================================================
4371
4372	IF (prt_level.ge.1) THEN
4373	write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
4374	write(lunout,*) &
4375	'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos'
4376	write(lunout,*) &
4377	nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, &
4378	pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), &
4379	pctsrf(igout,is_sic)
4380	write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva'
4381	DO k=1,klev
4382	write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), &
4383	d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), &
4384	d_t_eva(igout,k)
4385	ENDDO
4386	write(lunout,*) 'cool,heat'
4387	DO k=1,klev
4388	write(lunout,*) cool(igout,k),heat(igout,k)
4389	ENDDO
4390
4391	!jyg< (En attendant de statuer sur le sort de d_t_oli)
4392	!jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec'
4393	!jyg! do k=1,klev
4394	!jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), &
4395	!jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
4396	!jyg! enddo
4397	write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec'
4398	DO k=1,klev
4399	write(lunout,*) d_t_vdf(igout,k), &
4400	d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
4401	ENDDO
4402	!>jyg
4403
4404	write(lunout,*) 'd_ps ',d_ps(igout)
4405	write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 '
4406	DO k=1,klev
4407	write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), &
4408	d_qx(igout,k,1),d_qx(igout,k,2)
4409	ENDDO
4410	ENDIF
4411
4412	!============================================================
4413	! Calcul de la temperature potentielle
4414	!============================================================
4415	DO k = 1, klev
4416	DO i = 1, klon
4417	!JYG/IM theta en debut du pas de temps
4418	!JYG/IM theta(i,k)=t(i,k)(100000./pplay(i,k))*(RD/RCPD)
4419	!JYG/IM theta en fin de pas de temps de physique
4420	theta(i,k)=t_seri(i,k)(100000./pplay(i,k))*(RD/RCPD)
4421	! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers
4422	! MPL 20130625
4423	! fth_fonctions.F90 et parkind1.F90
4424	! sinon thetal=theta
4425	! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k),
4426	! : ql_seri(i,k))
4427	thetal(i,k)=theta(i,k)
4428	ENDDO
4429	ENDDO
4430	!
4431
4432	! 22.03.04 BEG
4433	!=============================================================
4434	! Ecriture des sorties
4435	!=============================================================
4436	#ifdef CPP_IOIPSL
4437
4438	! Recupere des varibles calcule dans differents modules
4439	! pour ecriture dans histxxx.nc
4440
4441	! Get some variables from module fonte_neige_mod
4442	CALL fonte_neige_get_vars(pctsrf, &
4443	zxfqcalving, zxfqfonte, zxffonte, zxrunofflic)
4444
4445
4446	!=============================================================
4447	! Separation entre thermiques et non thermiques dans les sorties
4448	! de fisrtilp
4449	!=============================================================
4450
4451	IF (iflag_thermals>=1) THEN
4452	d_t_lscth=0.
4453	d_t_lscst=0.
4454	d_q_lscth=0.
4455	d_q_lscst=0.
4456	DO k=1,klev
4457	DO i=1,klon
4458	IF (ptconvth(i,k)) THEN
4459	d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
4460	d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
4461	ELSE
4462	d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
4463	d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
4464	ENDIF
4465	ENDDO
4466	ENDDO
4467
4468	DO i=1,klon
4469	plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1)
4470	plul_th(i)=prfl(i,1)+psfl(i,1)
4471	ENDDO
4472	ENDIF
4473
4474	!On effectue les sorties:
4475
4476	#ifdef CPP_Dust
4477	CALL phys_output_write_spl(itap, pdtphys, paprs, pphis, &
4478	pplay, lmax_th, aerosol_couple, &
4479	ok_ade, ok_aie, ivap, new_aod, ok_sync, &
4480	ptconv, read_climoz, clevSTD, &
4481	ptconvth, d_t, qx, d_qx, d_tr_dyn, zmasse, &
4482	flag_aerosol, flag_aerosol_strat, ok_cdnc)
4483	#else
4484	CALL phys_output_write(itap, pdtphys, paprs, pphis, &
4485	pplay, lmax_th, aerosol_couple, &
4486	ok_ade, ok_aie, ivap, iliq, isol, new_aod, &
4487	ok_sync, ptconv, read_climoz, clevSTD, &
4488	ptconvth, d_u, d_t, qx, d_qx, zmasse, &
4489	flag_aerosol, flag_aerosol_strat, ok_cdnc)
4490	#endif
4491
4492	#ifndef CPP_XIOS
4493	CALL write_paramLMDZ_phy(itap,nid_ctesGCM,ok_sync)
4494	#endif
4495
4496	#endif
4497
4498
4499	!====================================================================
4500	! Arret du modele apres hgardfou en cas de detection d'un
4501	! plantage par hgardfou
4502	!====================================================================
4503
4504	IF (abortphy==1) THEN
4505	abort_message ='Plantage hgardfou'
4506	CALL abort_physic (modname,abort_message,1)
4507	ENDIF
4508
4509	! 22.03.04 END
4510	!
4511	!====================================================================
4512	! Si c'est la fin, il faut conserver l'etat de redemarrage
4513	!====================================================================
4514	!
4515
4516	IF (lafin) THEN
4517	itau_phy = itau_phy + itap
4518	CALL phyredem ("restartphy.nc")
4519	! open(97,form="unformatted",file="finbin")
4520	! write(97) u_seri,v_seri,t_seri,q_seri
4521	! close(97)
4522	!$OMP MASTER
4523	IF (read_climoz >= 1) THEN
4524	IF (is_mpi_root) THEN
4525	CALL nf95_close(ncid_climoz)
4526	ENDIF
4527	DEALLOCATE(press_edg_climoz) ! pointer
4528	DEALLOCATE(press_cen_climoz) ! pointer
4529	ENDIF
4530	!$OMP END MASTER
4531	ENDIF
4532
4533	! first=.false.
4534
4535
4536	END SUBROUTINE physiq
4537
4538	END MODULE physiq_mod

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

Download in other formats:

Original Format