Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

physiq_mod.F90 @ 3992

Last change on this file since 3992 was 3331, checked in by acozic, 6 years ago
Add modification for isotopes
Property svn:executable set to ``*
File size: 225.4 KB

Line
1	!
2	! $Id: physiq_mod.F90 2618 2016-09-01 08:47:39Z oboucher $
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 ioipsl, only: histbeg, histvert, histdef, histend, histsync, &
19	histwrite, ju2ymds, ymds2ju, getin
20	USE geometry_mod, ONLY: cell_area, latitude_deg, longitude_deg
21	USE phys_cal_mod, only: year_len, mth_len, days_elapsed, jh_1jan, &
22	year_cur, mth_cur,jD_cur, jH_cur, jD_ref
23	USE write_field_phy
24	USE dimphy
25	USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac,ok_isotopes
26	#ifdef ISO
27	USE infotrac_phy, ONLY: &
28	iqiso,iso_num,iso_indnum,zone_num,ok_isotrac, &
29	niso,ntraciso,nqtottr,itr_indice ! ajout C Risi pour isos
30	#endif
31	#ifdef ISO
32	USE isotopes_mod, ONLY: iso_eau,iso_HDO,iso_O18,iso_O17,iso_HTO, &
33	& bidouille_anti_divergence,ok_bidouille_wake, &
34	& modif_ratqs,essai_convergence,iso_init,ridicule_rain,tnat, &
35	& ridicule,ridicule_snow
36	USE isotopes_routines_mod, ONLY: iso_tritium
37	#ifdef ISOVERIF
38	USE isotopes_verif_mod, ONLY: errmax,errmaxrel, &
39	& deltalim,deltalim_snow, deltaD,deltaO,nlevmaxO17, &
40	& iso_verif_positif_nostop,iso_verif_egalite_vect2D, &
41	& iso_verif_aberrant_enc_vect2D,iso_verif_noNaN_vect2D, &
42	& iso_verif_noNaN,iso_verif_aberrant_vect2D, &
43	& iso_verif_o18_aberrant,iso_verif_aberrant_o17, &
44	& iso_verif_aberrant,iso_verif_egalite_choix, &
45	& iso_verif_aberrant_encadre,iso_verif_egalite, &
46	& iso_verif_aberrant_choix,iso_verif_positif, &
47	& iso_verif_positif_choix_vect,iso_verif_o18_aberrant_nostop, &
48	& iso_verif_init, &
49	& iso_verif_positif_strict_nostop,iso_verif_O18_aberrant_enc_vect2D
50	#endif
51	#ifdef ISOTRAC
52	USE isotrac_mod, ONLY: option_traceurs,iso_traceurs_init, &
53	& option_tmin,nzone_temp
54	USE isotrac_routines_mod, only: initialise_bassins_boites, &
55	& isotrac_recolorise_general,isotrac_recolorise_conv, &
56	& iso_verif_traceur_jbid_vect
57	#ifdef ISOVERIF
58	USE isotrac_routines_mod, only: iso_verif_traceur_pbidouille
59	USE isotopes_verif_mod, ONLY: iso_verif_traceur, &
60	& iso_verif_traceur_justmass,iso_verif_traceur_vect, &
61	& iso_verif_trac17_q_deltad,iso_verif_trac_masse_vect, &
62	& iso_verif_tracpos_choix_nostop
63	#endif
64	#endif
65	#endif
66	USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo
67	USE mod_phys_lmdz_para
68	USE iophy
69	USE print_control_mod, ONLY: mydebug=>debug , lunout, prt_level
70	USE phystokenc_mod, ONLY: offline, phystokenc
71	USE time_phylmdz_mod, only: raz_date, day_step_phy, update_time
72	USE vampir
73	USE pbl_surface_mod, ONLY : pbl_surface
74	USE change_srf_frac_mod
75	USE surface_data, ONLY : type_ocean, ok_veget, ok_snow
76	USE phys_local_var_mod, ONLY: phys_local_var_init, phys_local_var_end, &
77	! [Variables internes non sauvegardees de la physique]
78	! Variables locales pour effectuer les appels en serie
79	t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,tr_seri, &
80	! Dynamic tendencies (diagnostics)
81	d_t_dyn,d_q_dyn,d_ql_dyn,d_qs_dyn,d_u_dyn,d_v_dyn,d_tr_dyn, &
82	d_q_dyn2d,d_ql_dyn2d,d_qs_dyn2d, &
83	! Physic tendencies
84	d_t_con,d_q_con,d_u_con,d_v_con, &
85	d_tr, & !! to be removed?? (jyg)
86	d_t_wake,d_q_wake, &
87	d_t_lwr,d_t_lw0,d_t_swr,d_t_sw0, &
88	d_t_ajsb,d_q_ajsb, &
89	d_t_ajs,d_q_ajs,d_u_ajs,d_v_ajs, &
90	d_t_ajs_w,d_q_ajs_w, &
91	d_t_ajs_x,d_q_ajs_x, &
92	!
93	d_t_eva,d_q_eva, &
94	d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc, &
95	d_t_lscst,d_q_lscst, &
96	d_t_lscth,d_q_lscth, &
97	plul_st,plul_th, &
98	!
99	d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_t_diss, &
100	d_t_vdf_w,d_q_vdf_w, &
101	d_t_vdf_x,d_q_vdf_x, &
102	d_ts, &
103	!
104	d_t_oli,d_u_oli,d_v_oli, &
105	d_t_oro,d_u_oro,d_v_oro, &
106	d_t_lif,d_u_lif,d_v_lif, &
107	d_t_ec, &
108	!
109	du_gwd_hines,dv_gwd_hines,d_t_hin, &
110	dv_gwd_rando,dv_gwd_front, &
111	east_gwstress,west_gwstress, &
112	d_q_ch4, &
113	! Special RRTM
114	ZLWFT0_i,ZSWFT0_i,ZFLDN0, &
115	ZFLUP0,ZFSDN0,ZFSUP0, &
116	!
117	topswad_aero,solswad_aero, &
118	topswai_aero,solswai_aero, &
119	topswad0_aero,solswad0_aero, &
120	!LW additional
121	toplwad_aero,sollwad_aero, &
122	toplwai_aero,sollwai_aero, &
123	toplwad0_aero,sollwad0_aero, &
124	!
125	topsw_aero,solsw_aero, &
126	topsw0_aero,solsw0_aero, &
127	topswcf_aero,solswcf_aero, &
128	tausum_aero,tau3d_aero, &
129	!
130	!variables CFMIP2/CMIP5
131	topswad_aerop, solswad_aerop, &
132	topswai_aerop, solswai_aerop, &
133	topswad0_aerop, solswad0_aerop, &
134	topsw_aerop, topsw0_aerop, &
135	solsw_aerop, solsw0_aerop, &
136	topswcf_aerop, solswcf_aerop, &
137	!LW diagnostics
138	toplwad_aerop, sollwad_aerop, &
139	toplwai_aerop, sollwai_aerop, &
140	toplwad0_aerop, sollwad0_aerop, &
141	!
142	ptstar, pt0, slp, &
143	!
144	bils, &
145	!
146	cldh, cldl,cldm, cldq, cldt, &
147	JrNt, &
148	dthmin, evap, fder, plcl, plfc, &
149	prw, prlw, prsw, &
150	s_lcl, s_pblh, s_pblt, s_therm, &
151	cdragm, cdragh, &
152	zustar, zu10m, zv10m, rh2m, qsat2m, &
153	zq2m, zt2m, weak_inversion, &
154	zt2m_min_mon, zt2m_max_mon, & ! pour calcul_divers.h
155	t2m_min_mon, t2m_max_mon, & ! pour calcul_divers.h
156	!
157	s_pblh_x, s_pblh_w, &
158	s_lcl_x, s_lcl_w, &
159	!
160	slab_wfbils, tpot, tpote, &
161	ue, uq, ve, vq, zxffonte, &
162	zxfqcalving, zxfluxlat, &
163	zxrunofflic, &
164	zxtsol, snow_lsc, zxfqfonte, zxqsurf, &
165	rain_lsc, rain_num, &
166	!
167	sens_x, sens_w, &
168	zxfluxlat_x, zxfluxlat_w, &
169	!
170	dtvdf_x, dtvdf_w, &
171	dqvdf_x, dqvdf_w, &
172	undi_tke, wake_tke, &
173	pbl_tke_input, &
174	t_therm, q_therm, u_therm, v_therm, &
175	cdragh_x, cdragh_w, &
176	cdragm_x, cdragm_w, &
177	kh, kh_x, kh_w, &
178	!
179	ale_wake, alp_wake, &
180	wake_h, wbeff, zmax_th, &
181	sens, flwp, fiwp, &
182	ale_bl_stat,alp_bl_conv,alp_bl_det, &
183	alp_bl_fluct_m,alp_bl_fluct_tke, &
184	alp_bl_stat, n2, s2, &
185	proba_notrig, random_notrig, &
186	!
187	dnwd, dnwd0, &
188	upwd, omega, &
189	epmax_diag, &
190	ep, &
191	cldemi, &
192	cldfra, cldtau, fiwc, &
193	fl, re, flwc, &
194	ref_liq, ref_ice, theta, &
195	ref_liq_pi, ref_ice_pi, &
196	zphi, wake_omg, zx_rh, &
197	pmfd, pmfu, &
198	!
199	t2m, fluxlat, &
200	fsollw, evap_pot, &
201	fsolsw, wfbils, wfbilo, &
202
203	pmflxr, pmflxs, prfl, &
204	psfl, fraca, Vprecip, &
205	zw2, &
206
207	fluxu, fluxv, &
208	fluxt, &
209
210	uwriteSTD, vwriteSTD, & !pour calcul_STDlev.h
211	wwriteSTD, phiwriteSTD, & !pour calcul_STDlev.h
212	qwriteSTD, twriteSTD, rhwriteSTD, & !pour calcul_STDlev.h
213
214	wdtrainA, wdtrainM, &
215	beta_prec, &
216	rneb, &
217	#ifdef ISO
218	xt_seri,xtl_seri,xts_seri, &
219	d_xt_dyn,d_xtl_dyn,d_xts_dyn, &
220	d_xt_con, d_xt_wake, &
221	d_xt_ajsb, d_xt_ajs, &
222	d_xt_ajs_w, d_xt_ajs_x, &
223	d_xt_vdf, d_xt_vdf_w, d_xt_vdf_x, &
224	d_xt_eva, d_xt_lsc, d_xtl_lsc, d_xti_lsc, &
225	d_xt_ch4,d_xt_prod_nucl,d_xt_cosmo,d_xt_decroiss, &
226	zxfxtcalving, xtevap,xtprw, &
227	xt_therm, dxtvdf_w, dxtvdf_x, &
228	zxfxtcalving, zxfxtfonte, &
229	zxxtrunofflic, & ! pas besoin du runoff, c'est seulement quand on couple à sisvat
230	h1_diag,runoff_diag,xtrunoff_diag,zxxtsnow,xtVprecip,xtVprecipi, &
231	xtrain_lsc,xtsnow_lsc,pxtrfl,pxtsfl, &
232	#endif
233	zxsnow,snowhgt,qsnow,to_ice,sissnow,runoff,albsol3_lic
234	!
235	USE phys_state_var_mod ! Variables sauvegardees de la physique
236	USE phys_output_var_mod ! Variables pour les ecritures des sorties
237	USE phys_output_write_mod
238	USE fonte_neige_mod, ONLY : fonte_neige_get_vars
239	USE phys_output_mod
240	USE phys_output_ctrlout_mod
241	USE iophy
242	use open_climoz_m, only: open_climoz ! ozone climatology from a file
243	use regr_pr_av_m, only: regr_pr_av
244	use netcdf95, only: nf95_close
245	!IM for NMC files
246	! use netcdf, only: nf90_fill_real
247	use netcdf
248	use mod_phys_lmdz_mpi_data, only: is_mpi_root
249	USE aero_mod
250	use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer
251	use conf_phys_m, only: conf_phys
252	use radlwsw_m, only: radlwsw
253	use phyaqua_mod, only: zenang_an
254	USE time_phylmdz_mod, only: day_step_phy, annee_ref, day_ref, itau_phy, &
255	start_time, pdtphys, day_ini
256	USE tracinca_mod, ONLY: config_inca
257	#ifdef CPP_XIOS
258	USE wxios, ONLY: missing_val, missing_val_omp
259	USE xios, ONLY: xios_get_field_attr
260	#endif
261	#ifdef REPROBUS
262	USE CHEM_REP, ONLY : Init_chem_rep_xjour
263	#endif
264	USE indice_sol_mod
265	USE phytrac_mod, ONLY : phytrac
266
267	#ifdef CPP_RRTM
268	USE YOERAD, ONLY : NRADLP
269	USE YOESW, ONLY : RSUN
270	#endif
271	USE ioipsl_getin_p_mod, ONLY : getin_p
272
273	USE paramLMDZ_phy_mod
274
275	USE cmp_seri_mod
276
277	!IM stations CFMIP
278	USE CFMIP_point_locations
279	use FLOTT_GWD_rando_m, only: FLOTT_GWD_rando
280	use ACAMA_GWD_rando_m, only: ACAMA_GWD_rando
281
282	IMPLICIT none
283	!>======================================================================
284	!!
285	!! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
286	!!
287	!! Objet: Moniteur general de la physique du modele
288	!!AA Modifications quant aux traceurs :
289	!!AA - uniformisation des parametrisations ds phytrac
290	!!AA - stockage des moyennes des champs necessaires
291	!!AA en mode traceur off-line
292	!!======================================================================
293	!! CLEFS CPP POUR LES IO
294	!! =====================
295	#define histNMC
296	!!======================================================================
297	!! modif ( P. Le Van , 12/10/98 )
298	!!
299	!! Arguments:
300	!!
301	!! nlon----input-I-nombre de points horizontaux
302	!! nlev----input-I-nombre de couches verticales, doit etre egale a klev
303	!! debut---input-L-variable logique indiquant le premier passage
304	!! lafin---input-L-variable logique indiquant le dernier passage
305	!! jD_cur -R-jour courant a l'appel de la physique (jour julien)
306	!! jH_cur -R-heure courante a l'appel de la physique (jour julien)
307	!! pdtphys-input-R-pas d'integration pour la physique (seconde)
308	!! paprs---input-R-pression pour chaque inter-couche (en Pa)
309	!! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
310	!! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
311	!! pphis---input-R-geopotentiel du sol
312	!! presnivs-input_R_pressions approximat. des milieux couches ( en PA)
313	!! u-------input-R-vitesse dans la direction X (de O a E) en m/s
314	!! v-------input-R-vitesse Y (de S a N) en m/s
315	!! t-------input-R-temperature (K)
316	!! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
317	!! d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
318	!! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
319	!! d_ql_dyn-input-R-tendance dynamique pour "ql" (kg/kg/s)
320	!! d_qs_dyn-input-R-tendance dynamique pour "qs" (kg/kg/s)
321	!! flxmass_w -input-R- flux de masse verticale
322	!! d_u-----output-R-tendance physique de "u" (m/s/s)
323	!! d_v-----output-R-tendance physique de "v" (m/s/s)
324	!! d_t-----output-R-tendance physique de "t" (K/s)
325	!! d_qx----output-R-tendance physique de "qx" (kg/kg/s)
326	!! d_ps----output-R-tendance physique de la pression au sol
327	!!======================================================================
328	integer jjmp1
329	! parameter (jjmp1=jjm+1-1/jjm) ! => (jjmp1=nbp_lat-1/(nbp_lat-1))
330	! integer iip1
331	! parameter (iip1=iim+1)
332
333	include "regdim.h"
334	include "dimsoil.h"
335	include "clesphys.h"
336	include "thermcell.h"
337	!======================================================================
338	LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE
339	PARAMETER (ok_cvl=.TRUE.)
340	LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
341	PARAMETER (ok_gust=.FALSE.)
342	integer iflag_radia ! active ou non le rayonnement (MPL)
343	save iflag_radia
344	!$OMP THREADPRIVATE(iflag_radia)
345	!======================================================================
346	LOGICAL check ! Verifier la conservation du modele en eau
347	PARAMETER (check=.FALSE.)
348	LOGICAL ok_stratus ! Ajouter artificiellement les stratus
349	PARAMETER (ok_stratus=.FALSE.)
350	!======================================================================
351	REAL amn, amx
352	INTEGER igout
353	!======================================================================
354	! Clef controlant l'activation du cycle diurne:
355	! en attente du codage des cles par Fred
356	INTEGER iflag_cycle_diurne
357	PARAMETER (iflag_cycle_diurne=1)
358	!======================================================================
359	! Modele thermique du sol, a activer pour le cycle diurne:
360	!cc LOGICAL soil_model
361	!cc PARAMETER (soil_model=.FALSE.)
362	!======================================================================
363	! Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
364	! le calcul du rayonnement est celle apres la precipitation des nuages.
365	! Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
366	! la condensation et la precipitation. Cette cle augmente les impacts
367	! radiatifs des nuages.
368	!cc LOGICAL new_oliq
369	!cc PARAMETER (new_oliq=.FALSE.)
370	!======================================================================
371	! Clefs controlant deux parametrisations de l'orographie:
372	!c LOGICAL ok_orodr
373	!cc PARAMETER (ok_orodr=.FALSE.)
374	!cc LOGICAL ok_orolf
375	!cc PARAMETER (ok_orolf=.FALSE.)
376	!======================================================================
377	LOGICAL ok_journe ! sortir le fichier journalier
378	save ok_journe
379	!$OMP THREADPRIVATE(ok_journe)
380	!
381	LOGICAL ok_mensuel ! sortir le fichier mensuel
382	save ok_mensuel
383	!$OMP THREADPRIVATE(ok_mensuel)
384	!
385	LOGICAL ok_instan ! sortir le fichier instantane
386	save ok_instan
387	!$OMP THREADPRIVATE(ok_instan)
388	!
389	LOGICAL ok_LES ! sortir le fichier LES
390	save ok_LES
391	!$OMP THREADPRIVATE(ok_LES)
392	!
393	LOGICAL callstats ! sortir le fichier stats
394	save callstats
395	!$OMP THREADPRIVATE(callstats)
396	!
397	LOGICAL ok_region ! sortir le fichier regional
398	PARAMETER (ok_region=.FALSE.)
399	!======================================================================
400	real seuil_inversion
401	save seuil_inversion
402	!$OMP THREADPRIVATE(seuil_inversion)
403	integer iflag_ratqs
404	save iflag_ratqs
405	!$OMP THREADPRIVATE(iflag_ratqs)
406	real facteur
407
408	REAL wmax_th(klon)
409	REAL tau_overturning_th(klon)
410
411	integer lmax_th(klon)
412	integer limbas(klon)
413	real ratqscth(klon,klev)
414	real ratqsdiff(klon,klev)
415	real zqsatth(klon,klev)
416
417	!======================================================================
418	!
419	INTEGER ivap ! indice de traceurs pour vapeur d'eau
420	PARAMETER (ivap=1)
421	INTEGER iliq ! indice de traceurs pour eau liquide
422	PARAMETER (iliq=2)
423	!CR: on ajoute la phase glace
424	INTEGER isol ! indice de traceurs pour eau glace
425	PARAMETER (isol=3)
426	!
427	!
428	! Variables argument:
429	!
430	INTEGER nlon
431	INTEGER nlev
432	REAL,INTENT(IN) :: pdtphys_
433	! NB: pdtphys to be used in physics is in time_phylmdz_mod
434	LOGICAL debut, lafin
435	REAL paprs(klon,klev+1)
436	REAL pplay(klon,klev)
437	REAL pphi(klon,klev)
438	REAL pphis(klon)
439	REAL presnivs(klev)
440	REAL znivsig(klev)
441	real pir
442
443	REAL u(klon,klev)
444	REAL v(klon,klev)
445
446	REAL, intent(in):: rot(klon, klev)
447	! relative vorticity, in s-1, needed for frontal waves
448
449	REAL t(klon,klev),thetal(klon,klev)
450	! thetal: ligne suivante a decommenter si vous avez les fichiers
451	! MPL 20130625
452	! fth_fonctions.F90 et parkind1.F90
453	! sinon thetal=theta
454	! REAL fth_thetae,fth_thetav,fth_thetal
455	REAL qx(klon,klev,nqtot)
456	REAL flxmass_w(klon,klev)
457	REAL d_u(klon,klev)
458	REAL d_v(klon,klev)
459	REAL d_t(klon,klev)
460	REAL d_qx(klon,klev,nqtot)
461	REAL d_ps(klon)
462	! Variables pour le transport convectif
463	real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
464	real wght_cvfd(klon,klev)
465	#ifndef CPP_XIOS
466	REAL, SAVE :: missing_val
467	#endif
468	! Variables pour le lessivage convectif
469	! RomP >>>
470	real phi2(klon,klev,klev)
471	real d1a(klon,klev),dam(klon,klev)
472	real ev(klon,klev)
473	real clw(klon,klev),elij(klon,klev,klev)
474	real epmlmMm(klon,klev,klev),eplaMm(klon,klev)
475	! RomP <<<
476	!IM definition dynamique o_trac dans phys_output_open
477	! type(ctrl_out) :: o_trac(nqtot)
478
479	! variables a une pression donnee
480	!
481	include "declare_STDlev.h"
482	!
483	!
484	include "radopt.h"
485	!
486	!
487	INTEGER debug
488	INTEGER n
489	!ym INTEGER npoints
490	!ym PARAMETER(npoints=klon)
491	!
492	INTEGER nregISCtot
493	PARAMETER(nregISCtot=1)
494	!
495	! imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties
496	! sur 1 region rectangulaire y compris pour 1 point
497	! imin_debut : indice minimum de i; nbpti : nombre de points en
498	! direction i (longitude)
499	! jmin_debut : indice minimum de j; nbptj : nombre de points en
500	! direction j (latitude)
501	INTEGER imin_debut, nbpti
502	INTEGER jmin_debut, nbptj
503	!IM: region='3d' <==> sorties en global
504	CHARACTER*3 region
505	PARAMETER(region='3d')
506	logical ok_hf
507	!
508	save ok_hf
509	!$OMP THREADPRIVATE(ok_hf)
510
511	INTEGER,PARAMETER :: longcles=20
512	REAL,SAVE :: clesphy0(longcles)
513	!$OMP THREADPRIVATE(clesphy0)
514	!
515	! Variables propres a la physique
516	INTEGER itap
517	SAVE itap ! compteur pour la physique
518	!$OMP THREADPRIVATE(itap)
519
520	INTEGER, SAVE :: abortphy=0 ! Reprere si on doit arreter en fin de phys
521	!$OMP THREADPRIVATE(abortphy)
522	!
523	REAL,save :: solarlong0
524	!$OMP THREADPRIVATE(solarlong0)
525
526	!
527	! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
528	!
529	!IM 141004 REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
530	REAL zulow(klon),zvlow(klon)
531	!
532	INTEGER igwd,idx(klon),itest(klon)
533	!
534	! REAL,allocatable,save :: run_off_lic_0(:)
535	! !$OMP THREADPRIVATE(run_off_lic_0)
536	!ym SAVE run_off_lic_0
537	!KE43
538	! Variables liees a la convection de K. Emanuel (sb):
539	!
540	REAL bas, top ! cloud base and top levels
541	SAVE bas
542	SAVE top
543	!$OMP THREADPRIVATE(bas, top)
544	!------------------------------------------------------------------
545	! Upmost level reached by deep convection and related variable (jyg)
546	!
547	INTEGER izero
548	INTEGER k_upper_cv
549	!------------------------------------------------------------------
550	!
551	!==========================================================================
552	!CR04.12.07: on ajoute les nouvelles variables du nouveau schema
553	!de convection avec poches froides
554	! Variables li\'ees \`a la poche froide (jyg)
555
556	REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level
557	!
558	REAL wape_prescr, fip_prescr
559	INTEGER it_wape_prescr
560	SAVE wape_prescr, fip_prescr, it_wape_prescr
561	!$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr)
562	!
563	! variables supplementaires de concvl
564	REAL Tconv(klon,klev)
565	REAL sij(klon,klev,klev)
566
567	real, save :: alp_bl_prescr=0.
568	real, save :: ale_bl_prescr=0.
569
570	real, save :: wake_s_min_lsp=0.1
571
572	!$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr)
573	!$OMP THREADPRIVATE(wake_s_min_lsp)
574
575
576	real ok_wk_lsp(klon)
577
578	!RC
579	! Variables li\'ees \`a la poche froide (jyg et rr)
580	! Version diagnostique pour l'instant : pas de r\'etroaction sur
581	! la convection
582
583	REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection
584
585	REAL wake_dth(klon,klev) ! wake : temp pot difference
586
587	REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to
588	! Gravity Wave (/s)
589	REAL wake_omgbdth(klon,klev) ! Wake : flux of Delta_Theta
590	! transported by LS omega
591	REAL wake_dp_omgb(klon,klev) ! Wake : vertical gradient of
592	! large scale omega
593	REAL wake_dtKE(klon,klev) ! Wake : differential heating
594	! (wake - unpertubed) CONV
595	REAL wake_dqKE(klon,klev) ! Wake : differential moistening
596	! (wake - unpertubed) CONV
597	REAL wake_dtPBL(klon,klev) ! Wake : differential heating
598	! (wake - unpertubed) PBL
599	REAL wake_dqPBL(klon,klev) ! Wake : differential moistening
600	! (wake - unpertubed) PBL
601	REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
602	REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg
603	REAL wake_spread(klon,klev) ! spreading term in wake_delt
604	!
605	!pourquoi y'a pas de save??
606	!
607	INTEGER wake_k(klon) ! Wake sommet
608	!
609	REAL t_undi(klon,klev) ! temperature moyenne dans la zone
610	! non perturbee
611	REAL q_undi(klon,klev) ! humidite moyenne dans la zone
612	! non perturbee
613	#ifdef ISO
614	REAL xt_wake(ntraciso,klon,klev)
615	REAL wake_dxtKE(ntraciso,klon,klev)
616	REAL wake_dxtPBL(ntraciso,klon,klev)
617	REAL xt_undi(ntraciso,klon,klev)
618	REAL dxt_dwn(ntraciso,klon,klev)
619	REAL wdxt_PBL(ntraciso,klon,klev)
620	REAL udxt_PBL(ntraciso,klon,klev)
621	REAL dxt_a(ntraciso,klon,klev)
622	REAL d_xt_adjwk(ntraciso,klon,klev)
623	#endif
624	!
625	!jyg<
626	!cc REAL wake_pe(klon) ! Wake potential energy - WAPE
627	!>jyg
628
629	REAL wake_gfl(klon) ! Gust Front Length
630	REAL wake_dens(klon)
631	!
632	!
633	REAL dt_dwn(klon,klev)
634	REAL dq_dwn(klon,klev)
635	REAL wdt_PBL(klon,klev)
636	REAL udt_PBL(klon,klev)
637	REAL wdq_PBL(klon,klev)
638	REAL udq_PBL(klon,klev)
639	REAL M_dwn(klon,klev)
640	REAL M_up(klon,klev)
641	REAL dt_a(klon,klev)
642	REAL dq_a(klon,klev)
643	REAL d_t_adjwk(klon,klev) !jyg
644	REAL d_q_adjwk(klon,klev) !jyg
645	LOGICAL,SAVE :: ok_adjwk=.FALSE.
646	!$OMP THREADPRIVATE(ok_adjwk)
647	REAL,SAVE :: oliqmax=999.
648	!$OMP THREADPRIVATE(oliqmax)
649	REAL, SAVE :: alp_offset
650	!$OMP THREADPRIVATE(alp_offset)
651
652	! !!
653	!=================================================================
654	! PROVISOIRE : DECOUPLAGE PBL/WAKE
655	! --------------------------------
656	REAL wake_deltat_sav(klon,klev)
657	REAL wake_deltaq_sav(klon,klev)
658	!=================================================================
659
660	!
661	!RR:fin declarations poches froides
662	!==========================================================================
663
664	REAL ztv(klon,klev),ztva(klon,klev)
665	REAL zpspsk(klon,klev)
666	REAL ztla(klon,klev),zqla(klon,klev)
667	REAL zthl(klon,klev)
668
669	!cc nrlmd le 10/04/2012
670
671	!--------Stochastic Boundary Layer Triggering: ALE_BL--------
672	!---Propri\'et\'es du thermiques au LCL
673	real zlcl_th(klon) ! Altitude du LCL calcul\'e
674	! continument (pcon dans
675	! thermcell_main.F90)
676	real fraca0(klon) ! Fraction des thermiques au LCL
677	real w0(klon) ! Vitesse des thermiques au LCL
678	real w_conv(klon) ! Vitesse verticale de grande \'echelle au LCL
679	real tke0(klon,klev+1) ! TKE au d\'ebut du pas de temps
680	real therm_tke_max0(klon) ! TKE dans les thermiques au LCL
681	real env_tke_max0(klon) ! TKE dans l'environnement au LCL
682
683	!---D\'eclenchement stochastique
684	integer :: tau_trig(klon)
685
686	REAL,SAVE :: random_notrig_max=1.
687	!$OMP THREADPRIVATE(random_notrig_max)
688
689	!--------Statistical Boundary Layer Closure: ALP_BL--------
690	!---Profils de TKE dans et hors du thermique
691	real therm_tke_max(klon,klev) ! Profil de TKE dans les thermiques
692	real env_tke_max(klon,klev) ! Profil de TKE dans l'environnement
693
694
695	!cc fin nrlmd le 10/04/2012
696
697	! Variables locales pour la couche limite (al1):
698	!
699	!Al1 REAL pblh(klon) ! Hauteur de couche limite
700	!Al1 SAVE pblh
701	!34EK
702	!
703	! Variables locales:
704	!
705	!AA
706	!AA Pour phytrac
707	REAL u1(klon) ! vents dans la premiere couche U
708	REAL v1(klon) ! vents dans la premiere couche V
709
710	!@$$ LOGICAL offline ! Controle du stockage ds "physique"
711	!@$$ PARAMETER (offline=.false.)
712	!@$$ INTEGER physid
713	REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
714	REAL frac_nucl(klon,klev) ! idem (nucleation)
715	! RomP >>>
716	REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt)
717	! RomP <<<
718
719	REAL :: calday
720
721	!IM cf FH pour Tiedtke 080604
722	REAL rain_tiedtke(klon),snow_tiedtke(klon)
723	!
724	!IM 050204 END
725	REAL devap(klon) ! evaporation et sa derivee
726	REAL dsens(klon) ! chaleur sensible et sa derivee
727	#ifdef ISO
728	REAL dxtevap(ntraciso,klon)
729	#endif
730	!
731	! Conditions aux limites
732	!
733	!
734	REAL :: day_since_equinox
735	! Date de l'equinoxe de printemps
736	INTEGER, parameter :: mth_eq=3, day_eq=21
737	REAL :: jD_eq
738
739	LOGICAL, parameter :: new_orbit = .true.
740
741	!
742	INTEGER lmt_pas
743	SAVE lmt_pas ! frequence de mise a jour
744	!$OMP THREADPRIVATE(lmt_pas)
745	real zmasse(klon, nbp_lev),exner(klon, nbp_lev)
746	! (column-density of mass of air in a cell, in kg m-2)
747	real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
748
749	!IM sorties
750	REAL un_jour
751	PARAMETER(un_jour=86400.)
752	INTEGER itapm1 !pas de temps de la physique du(es) mois precedents
753	SAVE itapm1 !mis a jour le dernier pas de temps du mois en cours
754	!$OMP THREADPRIVATE(itapm1)
755	!======================================================================
756	!
757	! Declaration des procedures appelees
758	!
759	EXTERNAL angle ! calculer angle zenithal du soleil
760	EXTERNAL alboc ! calculer l'albedo sur ocean
761	EXTERNAL ajsec ! ajustement sec
762	EXTERNAL conlmd ! convection (schema LMD)
763	!KE43
764	EXTERNAL conema3 ! convect4.3
765	EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie)
766	!AA
767	! JBM (3/14) fisrtilp_tr not loaded
768	! EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
769	! ! stockage des coefficients necessaires au
770	! ! lessivage OFF-LINE et ON-LINE
771	EXTERNAL hgardfou ! verifier les temperatures
772	EXTERNAL nuage ! calculer les proprietes radiatives
773	!C EXTERNAL o3cm ! initialiser l'ozone
774	EXTERNAL orbite ! calculer l'orbite terrestre
775	EXTERNAL phyetat0 ! lire l'etat initial de la physique
776	EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique
777	EXTERNAL suphel ! initialiser certaines constantes
778	EXTERNAL transp ! transport total de l'eau et de l'energie
779	!IM
780	EXTERNAL haut2bas !variables de haut en bas
781	EXTERNAL ini_undefSTD !initialise a 0 une variable a 1 niveau de pression
782	EXTERNAL undefSTD !somme les valeurs definies d'1 var a 1 niveau de pression
783	! EXTERNAL moy_undefSTD !moyenne d'1 var a 1 niveau de pression
784	! EXTERNAL moyglo_aire
785	! moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
786	! par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
787	!
788	!
789	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
790	! Local variables
791	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
792	!
793	REAL rhcl(klon,klev) ! humiditi relative ciel clair
794	REAL dialiq(klon,klev) ! eau liquide nuageuse
795	REAL diafra(klon,klev) ! fraction nuageuse
796	REAL cldliq(klon,klev) ! eau liquide nuageuse
797	!
798	!XXX PB
799	REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite
800	!
801	REAL zxfluxt(klon, klev)
802	REAL zxfluxq(klon, klev)
803	REAL zxfluxu(klon, klev)
804	REAL zxfluxv(klon, klev)
805	#ifdef ISO
806	real fluxxt(ntraciso,klon,klev, nbsrf)
807	REAL zxfluxxt(ntraciso,klon, klev)
808	#endif
809
810	! Le rayonnement n'est pas calcule tous les pas, il faut donc
811	! sauvegarder les sorties du rayonnement
812	!ym SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
813	!ym SAVE sollwdownclr, toplwdown, toplwdownclr
814	!ym SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0
815	!
816	INTEGER itaprad
817	SAVE itaprad
818	!$OMP THREADPRIVATE(itaprad)
819	!
820	REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
821	REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
822
823	!
824	! REAL zxsnow(klon)
825	REAL zxsnow_dummy(klon)
826	REAL zsav_tsol(klon)
827	!
828	REAL dist, rmu0(klon), fract(klon)
829	REAL zrmu0(klon), zfract(klon)
830	REAL zdtime, zdtime1, zdtime2, zlongi
831	!
832	REAL qcheck
833	REAL z_avant(klon), z_apres(klon), z_factor(klon)
834	LOGICAL zx_ajustq
835	!
836	REAL za, zb
837	REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp
838	real zqsat(klon,klev)
839	!
840	INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq,itr
841	#ifdef ISO
842	REAL zxta(ntraciso),zbxt,zxt_apres(ntraciso,klon)
843	REAL xt_iso(klon,klev),xtl_iso(klon,klev)
844	REAL zxt_factor(ntraciso,klon),zxt_avant(ntraciso,klon)
845	INTEGER ixt
846	real seuil_q_undi
847	parameter (seuil_q_undi=0.0)
848	real wake_deltaq_prec(klon,klev)
849	#endif
850	!
851	REAL t_coup
852	PARAMETER (t_coup=234.0)
853
854	!ym A voir plus tard !!
855	!ym REAL zx_relief(iim,jjmp1)
856	!ym REAL zx_aire(iim,jjmp1)
857	!
858	! Grandeurs de sorties
859	REAL s_capCL(klon)
860	REAL s_oliqCL(klon), s_cteiCL(klon)
861	REAL s_trmb1(klon), s_trmb2(klon)
862	REAL s_trmb3(klon)
863	!KE43
864	! Variables locales pour la convection de K. Emanuel (sb):
865
866	REAL tvp(klon,klev) ! virtual temp of lifted parcel
867	CHARACTER*40 capemaxcels !max(CAPE)
868
869	REAL rflag(klon) ! flag fonctionnement de convect
870	INTEGER iflagctrl(klon) ! flag fonctionnement de convect
871
872	! -- convect43:
873	INTEGER ntra ! nb traceurs pour convect4.3
874	REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
875	REAL dplcldt(klon), dplcldr(klon)
876	!? . condm_con(klon,klev),conda_con(klon,klev),
877	!? . mr_con(klon,klev),ep_con(klon,klev)
878	!? . ,sadiab(klon,klev),wadiab(klon,klev)
879	! --
880	!34EK
881	!
882	! Variables du changement
883	!
884	! con: convection
885	! lsc: condensation a grande echelle (Large-Scale-Condensation)
886	! ajs: ajustement sec
887	! eva: evaporation de l'eau liquide nuageuse
888	! vdf: couche limite (Vertical DiFfusion)
889	!
890	! tendance nulles
891	REAL, dimension(klon,klev):: du0, dv0, dt0, dq0, dql0, dqi0
892	#ifdef ISO
893	REAL, dimension(ntraciso,klon,klev):: dxt0, dxtl0, dxti0
894	#endif
895	!
896	! Flag pour pouvoir ne pas ajouter les tendances.
897	! Par defaut, les tendances doivente etre ajoutees et
898	! flag_inhib_tend = 0
899	! flag_inhib_tend > 0 : tendances non ajoutees, avec un nombre
900	! croissant de print quand la valeur du flag augmente
901	!!! attention, ce flag doit etre change avec prudence !!!
902	INTEGER :: flag_inhib_tend = 0 ! 0 is the default value
903	!! INTEGER :: flag_inhib_tend = 2
904
905	!
906	!********************************************************
907	! declarations
908
909	!********************************************************
910	!IM 081204 END
911	!
912	REAL pen_u(klon,klev), pen_d(klon,klev)
913	REAL pde_u(klon,klev), pde_d(klon,klev)
914	INTEGER kcbot(klon), kctop(klon), kdtop(klon)
915	!
916	REAL ratqsc(klon,klev)
917	real ratqsbas,ratqshaut,tau_ratqs
918	save ratqsbas,ratqshaut,tau_ratqs
919	!$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs)
920	REAL, SAVE :: ratqsp0=50000., ratqsdp=20000.
921	!$OMP THREADPRIVATE(ratqsp0, ratqsdp)
922
923	! Parametres lies au nouveau schema de nuages (SB, PDF)
924	real fact_cldcon
925	real facttemps
926	logical ok_newmicro
927	save ok_newmicro
928	!$OMP THREADPRIVATE(ok_newmicro)
929	!real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev)
930	save fact_cldcon,facttemps
931	!$OMP THREADPRIVATE(fact_cldcon,facttemps)
932
933	integer iflag_cld_th
934	save iflag_cld_th
935	!$OMP THREADPRIVATE(iflag_cld_th)
936	logical ptconv(klon,klev)
937	!IM cf. AM 081204 BEG
938	logical ptconvth(klon,klev)
939	!IM cf. AM 081204 END
940	!
941	! Variables liees a l'ecriture de la bande histoire physique
942	!
943	!======================================================================
944	!
945
946	!
947	integer itau_w ! pas de temps ecriture = itap + itau_phy
948	!
949	!
950	! Variables locales pour effectuer les appels en serie
951	!
952	!IM RH a 2m (la surface)
953	REAL Lheat
954
955	INTEGER length
956	PARAMETER ( length = 100 )
957	REAL tabcntr0( length )
958	!
959	INTEGER ndex2d(nbp_lon*nbp_lat)
960	!IM
961	!
962	!IM AMIP2 BEG
963	REAL moyglo, mountor
964	!IM 141004 BEG
965	REAL zustrdr(klon), zvstrdr(klon)
966	REAL zustrli(klon), zvstrli(klon)
967	REAL zustrph(klon), zvstrph(klon)
968	REAL aam, torsfc
969	!IM 141004 END
970	!IM 190504 BEG
971	INTEGER ij
972	! INTEGER imp1jmp1
973	! PARAMETER(imp1jmp1=(iim+1)*jjmp1)
974	!ym A voir plus tard
975	! REAL zx_tmp((nbp_lon+1)*nbp_lat)
976	! REAL airedyn(nbp_lon+1,nbp_lat)
977	!IM 190504 END
978	LOGICAL ok_msk
979	REAL msk(klon)
980	!IM
981	REAL airetot, pi
982	!ym A voir plus tard
983	!ym REAL zm_wo(jjmp1, klev)
984	!IM AMIP2 END
985	!
986	REAL zx_tmp_fi2d(klon) ! variable temporaire grille physique
987	REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D
988	REAL zx_tmp_2d(nbp_lon,nbp_lat)
989	REAL zx_lon(nbp_lon,nbp_lat)
990	REAL zx_lat(nbp_lon,nbp_lat)
991	!
992	INTEGER nid_day_seri, nid_ctesGCM
993	SAVE nid_day_seri, nid_ctesGCM
994	!$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM)
995	!
996	!IM 280405 BEG
997	! INTEGER nid_bilKPins, nid_bilKPave
998	! SAVE nid_bilKPins, nid_bilKPave
999	! !$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
1000	!
1001	REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
1002	REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
1003	REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
1004	REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
1005	!
1006	REAL zjulian
1007	SAVE zjulian
1008	!$OMP THREADPRIVATE(zjulian)
1009
1010	INTEGER nhori, nvert
1011	REAL zsto
1012	REAL zstophy, zout
1013
1014	character*20 modname
1015	character*80 abort_message
1016	logical, save :: ok_sync, ok_sync_omp
1017	!$OMP THREADPRIVATE(ok_sync)
1018	real date0
1019	integer idayref
1020
1021	! essai writephys
1022	integer fid_day, fid_mth, fid_ins
1023	parameter (fid_ins = 1, fid_day = 2, fid_mth = 3)
1024	integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
1025	parameter (prof2d_on = 1, prof3d_on = 2, &
1026	prof2d_av = 3, prof3d_av = 4)
1027	! Variables liees au bilan d'energie et d'enthalpi
1028	REAL ztsol(klon)
1029	REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
1030	REAL d_h_vcol_phy
1031	REAL fs_bound, fq_bound
1032	SAVE d_h_vcol_phy
1033	!$OMP THREADPRIVATE(d_h_vcol_phy)
1034	REAL zero_v(klon)
1035	CHARACTER*40 ztit
1036	INTEGER ip_ebil ! PRINT level for energy conserv. diag.
1037	SAVE ip_ebil
1038	DATA ip_ebil/0/
1039	!$OMP THREADPRIVATE(ip_ebil)
1040	INTEGER if_ebil ! level for energy conserv. dignostics
1041	SAVE if_ebil
1042	!$OMP THREADPRIVATE(if_ebil)
1043	REAL q2m(klon,nbsrf) ! humidite a 2m
1044	#ifdef ISO
1045	REAL d_xtw(ntraciso),d_xtl(ntraciso), d_xts(ntraciso)
1046	#endif
1047
1048	!IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels
1049	CHARACTER*40 t2mincels, t2maxcels !t2m min., t2m max
1050	CHARACTER*40 tinst, tave, typeval
1051	REAL cldtaupi(klon,klev) ! Cloud optical thickness for
1052	! pre-industrial (pi) aerosols
1053
1054
1055	! Aerosol optical properties
1056	CHARACTER*4, DIMENSION(naero_grp) :: rfname
1057	REAL, DIMENSION(klon,klev) :: mass_solu_aero ! total mass
1058	! concentration
1059	! for all soluble
1060	! aerosols[ug/m3]
1061	REAL, DIMENSION(klon,klev) :: mass_solu_aero_pi
1062	! - " - (pre-industrial value)
1063
1064	! Parameters
1065	LOGICAL ok_ade, ok_aie ! Apply aerosol (in)direct effects or not
1066	LOGICAL ok_cdnc ! ok cloud droplet number concentration (O. Boucher 01-2013)
1067	REAL bl95_b0, bl95_b1 ! Parameter in Boucher and Lohmann (1995)
1068	SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1
1069	!$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1)
1070	LOGICAL, SAVE :: aerosol_couple ! true : calcul des aerosols dans INCA
1071	! false : lecture des aerosol dans un fichier
1072	!$OMP THREADPRIVATE(aerosol_couple)
1073	INTEGER, SAVE :: flag_aerosol
1074	!$OMP THREADPRIVATE(flag_aerosol)
1075	LOGICAL, SAVE :: new_aod
1076	!$OMP THREADPRIVATE(new_aod)
1077	!
1078	!--STRAT AEROSOL
1079	INTEGER, SAVE :: flag_aerosol_strat
1080	!$OMP THREADPRIVATE(flag_aerosol_strat)
1081	!c-fin STRAT AEROSOL
1082	!
1083	! Declaration des constantes et des fonctions thermodynamiques
1084	!
1085	LOGICAL,SAVE :: first=.true.
1086	!$OMP THREADPRIVATE(first)
1087
1088	integer, save:: read_climoz ! read ozone climatology
1089	! (let it keep the default OpenMP shared attribute)
1090	! Allowed values are 0, 1 and 2
1091	! 0: do not read an ozone climatology
1092	! 1: read a single ozone climatology that will be used day and night
1093	! 2: read two ozone climatologies, the average day and night
1094	! climatology and the daylight climatology
1095
1096	integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies
1097	! (let it keep the default OpenMP shared attribute)
1098
1099	real, pointer, save:: press_climoz(:)
1100	! (let it keep the default OpenMP shared attribute)
1101	! edges of pressure intervals for ozone climatologies, in Pa, in strictly
1102	! ascending order
1103
1104	integer, save:: co3i = 0
1105	! time index in NetCDF file of current ozone fields
1106	!$OMP THREADPRIVATE(co3i)
1107
1108	integer ro3i
1109	! required time index in NetCDF file for the ozone fields, between 1
1110	! and 360
1111
1112	INTEGER ierr
1113	include "YOMCST.h"
1114	include "YOETHF.h"
1115	include "FCTTRE.h"
1116	!IM 100106 BEG : pouvoir sortir les ctes de la physique
1117	include "conema3.h"
1118	include "fisrtilp.h"
1119	include "nuage.h"
1120	include "compbl.h"
1121	!IM 100106 END : pouvoir sortir les ctes de la physique
1122	!
1123	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1124	! Declarations pour Simulateur COSP
1125	!============================================================
1126	real :: mr_ozone(klon,klev)
1127
1128	!IM stations CFMIP
1129	INTEGER, SAVE :: nCFMIP
1130	!$OMP THREADPRIVATE(nCFMIP)
1131	INTEGER, PARAMETER :: npCFMIP=120
1132	INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:)
1133	REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:)
1134	!$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP)
1135	INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:)
1136	REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:)
1137	!$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM)
1138	INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:)
1139	!$OMP THREADPRIVATE(iGCM, jGCM)
1140	logical, dimension(nfiles) :: phys_out_filestations
1141	logical, parameter :: lNMC=.FALSE.
1142
1143	!IM betaCRF
1144	REAL, SAVE :: pfree, beta_pbl, beta_free
1145	!$OMP THREADPRIVATE(pfree, beta_pbl, beta_free)
1146	REAL, SAVE :: lon1_beta, lon2_beta, lat1_beta, lat2_beta
1147	!$OMP THREADPRIVATE(lon1_beta, lon2_beta, lat1_beta, lat2_beta)
1148	LOGICAL, SAVE :: mskocean_beta
1149	!$OMP THREADPRIVATE(mskocean_beta)
1150	REAL, dimension(klon, klev) :: beta ! facteur sur cldtaurad et
1151	! cldemirad pour evaluer les
1152	! retros liees aux CRF
1153	REAL, dimension(klon, klev) :: cldtaurad ! epaisseur optique
1154	! pour radlwsw pour
1155	! tester "CRF off"
1156	REAL, dimension(klon, klev) :: cldtaupirad ! epaisseur optique
1157	! pour radlwsw pour
1158	! tester "CRF off"
1159	REAL, dimension(klon, klev) :: cldemirad ! emissivite pour
1160	! radlwsw pour tester
1161	! "CRF off"
1162	REAL, dimension(klon, klev) :: cldfrarad ! fraction nuageuse
1163
1164	INTEGER :: nbtr_tmp ! Number of tracer inside concvl
1165	REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac
1166	integer iostat
1167
1168	REAL zzz
1169	!albedo SB >>>
1170	real,dimension(6),save :: SFRWL
1171	!albedo SB <<<
1172
1173	!--OB variables for mass fixer (hard coded for now)
1174	logical, parameter :: mass_fixer=.false.
1175	real qql1(klon),qql2(klon),zdz,corrqql
1176	#ifdef ISO
1177	real xtql1(ntraciso,klon),xtql2(ntraciso,klon),corrxtql(ntraciso)
1178	#endif
1179
1180	! Ehouarn: set value of jjmp1 since it is no longer a "fixed parameter"
1181	jjmp1=nbp_lat
1182
1183	!======================================================================
1184	! Gestion calendrier : mise a jour du module phys_cal_mod
1185	!
1186	pdtphys=pdtphys_
1187	CALL update_time(pdtphys)
1188
1189	!======================================================================
1190	! Ecriture eventuelle d'un profil verticale en entree de la physique.
1191	! Utilise notamment en 1D mais peut etre active egalement en 3D
1192	! en imposant la valeur de igout.
1193	!======================================================================d
1194	if (prt_level.ge.1) then
1195	igout=klon/2+1/klon
1196	write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
1197	write(lunout,*) 'igout, lat, lon ',igout, latitude_deg(igout), &
1198	longitude_deg(igout)
1199	write(lunout,*) &
1200	'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys'
1201	write(lunout,*) &
1202	nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys
1203
1204	write(lunout,*) 'paprs, play, phi, u, v, t'
1205	do k=1,klev
1206	write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k), &
1207	u(igout,k),v(igout,k),t(igout,k)
1208	enddo
1209	write(lunout,*) 'ovap (g/kg), oliq (g/kg)'
1210	do k=1,klev
1211	write(lunout,) qx(igout,k,1)1000,qx(igout,k,2)*1000.
1212	enddo
1213	endif
1214
1215	!======================================================================
1216
1217	if (first) then
1218
1219	!CR:nvelles variables convection/poches froides
1220
1221	print*, '================================================='
1222	print*, 'Allocation des variables locales et sauvegardees'
1223	call phys_local_var_init
1224	!
1225	pasphys=pdtphys
1226	! appel a la lecture du run.def physique
1227	call conf_phys(ok_journe, ok_mensuel, &
1228	ok_instan, ok_hf, &
1229	ok_LES, &
1230	callstats, &
1231	solarlong0,seuil_inversion, &
1232	fact_cldcon, facttemps,ok_newmicro,iflag_radia, &
1233	iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
1234	ok_ade, ok_aie, ok_cdnc, aerosol_couple, &
1235	flag_aerosol, flag_aerosol_strat, new_aod, &
1236	bl95_b0, bl95_b1, &
1237	! nv flags pour la convection et les
1238	! poches froides
1239	read_climoz, &
1240	alp_offset)
1241	call phys_state_var_init(read_climoz)
1242	call phys_output_var_init
1243	print*, '================================================='
1244	!
1245	!CR: check sur le nb de traceurs de l eau
1246	if ((iflag_ice_thermo.gt.0).and.(nqo==2)) then
1247	WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', &
1248	'(H2Ov, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.'
1249	STOP
1250	endif
1251
1252	dnwd0=0.0
1253	ftd=0.0
1254	fqd=0.0
1255	cin=0.
1256	!ym Attention pbase pas initialise dans concvl !!!!
1257	pbase=0
1258	!IM 180608
1259
1260	itau_con=0
1261	first=.false.
1262
1263	endif ! first
1264
1265	!ym => necessaire pour iflag_con != 2
1266	pmfd(:,:) = 0.
1267	pen_u(:,:) = 0.
1268	pen_d(:,:) = 0.
1269	pde_d(:,:) = 0.
1270	pde_u(:,:) = 0.
1271	aam=0.
1272	d_t_adjwk(:,:)=0
1273	d_q_adjwk(:,:)=0
1274	#ifdef ISO
1275	d_xt_adjwk(:,:,:)=0
1276	#endif
1277	alp_bl_conv(:)=0.
1278
1279	torsfc=0.
1280	forall (k=1: nbp_lev) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg
1281
1282	modname = 'physiq'
1283	!IM
1284	IF (ip_ebil_phy.ge.1) THEN
1285	DO i=1,klon
1286	zero_v(i)=0.
1287	END DO
1288	END IF
1289
1290	IF (debut) THEN
1291	CALL suphel ! initialiser constantes et parametres phys.
1292	CALL getin_p('random_notrig_max',random_notrig_max)
1293	CALL getin_p('ok_adjwk',ok_adjwk)
1294	CALL getin_p('oliqmax',oliqmax)
1295	CALL getin_p('ratqsp0',ratqsp0)
1296	CALL getin_p('ratqsdp',ratqsdp)
1297	ENDIF
1298
1299	if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 '
1300
1301
1302	!======================================================================
1303	! Gestion calendrier : mise a jour du module phys_cal_mod
1304	!
1305	! CALL phys_cal_update(jD_cur,jH_cur)
1306
1307	!
1308	! Si c'est le debut, il faut initialiser plusieurs choses
1309	! ********
1310	!
1311	IF (debut) THEN
1312	!rv CRinitialisation de wght_th et lalim_conv pour la
1313	!definition de la couche alimentation de la convection a partir
1314	!des caracteristiques du thermique
1315	wght_th(:,:)=1.
1316	lalim_conv(:)=1
1317	!RC
1318	ustar(:,:)=0.
1319	! u10m(:,:)=0.
1320	! v10m(:,:)=0.
1321	rain_con(:)=0.
1322	snow_con(:)=0.
1323	topswai(:)=0.
1324	topswad(:)=0.
1325	solswai(:)=0.
1326	solswad(:)=0.
1327
1328	wmax_th(:)=0.
1329	tau_overturning_th(:)=0.
1330
1331	IF (type_trac == 'inca') THEN
1332	! jg : initialisation jusqu'au ces variables sont dans restart
1333	ccm(:,:,:) = 0.
1334	tau_aero(:,:,:,:) = 0.
1335	piz_aero(:,:,:,:) = 0.
1336	cg_aero(:,:,:,:) = 0.
1337
1338	config_inca='none' ! default
1339	CALL getin_p('config_inca',config_inca)
1340
1341	ELSE
1342	config_inca='none' ! default
1343	END IF
1344
1345	IF (aerosol_couple .AND. (config_inca /= "aero" &
1346	.AND. config_inca /= "aeNP ")) THEN
1347	abort_message &
1348	= 'if aerosol_couple is activated, config_inca need to be ' &
1349	// 'aero or aeNP'
1350	CALL abort_physic (modname,abort_message,1)
1351	ENDIF
1352
1353
1354
1355	rnebcon0(:,:) = 0.0
1356	clwcon0(:,:) = 0.0
1357	rnebcon(:,:) = 0.0
1358	clwcon(:,:) = 0.0
1359
1360	!IM
1361	IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
1362	!
1363	print*,'iflag_coupl,iflag_clos,iflag_wake', &
1364	iflag_coupl,iflag_clos,iflag_wake
1365	print*,'iflag_CYCLE_DIURNE', iflag_cycle_diurne
1366	!
1367	IF (iflag_con.EQ.2.AND.iflag_cld_th.GT.-1) THEN
1368	abort_message = 'Tiedtke needs iflag_cld_th=-2 or -1'
1369	CALL abort_physic (modname,abort_message,1)
1370	ENDIF
1371	!
1372	!
1373	! Initialiser les compteurs:
1374	!
1375	itap = 0
1376	itaprad = 0
1377
1378	! C Risi: vérifier compatibilité des options isotopiques entre
1379	! dyn3dmem et physiq
1380	#ifdef ISO
1381	write(,) 'physiq 1846: ok_isotopes,ntraciso,niso=',ok_isotopes,ntraciso,niso
1382	if (.not.ok_isotopes) then
1383	CALL abort_gcm('physiq 1756','options iso incompatibles',1)
1384	endif
1385	#ifdef ISOTRAC
1386	if (.not.ok_isotrac) then
1387	CALL abort_gcm('physiq 1758','options isotrac incompatibles',1)
1388	endif
1389	#else
1390	! #ifdef ISOTRAC
1391	if (ok_isotrac) then
1392	CALL abort_gcm('physiq 1762','options isotrac incompatibles',1)
1393	endif
1394	#endif
1395	!! #ifdef ISOTRAC
1396	! -> on supprime opion ISOTRAC, tout passe par ok_isotrac
1397	#else
1398	! #ifdef ISO
1399	if (ok_isotopes) then
1400	CALL abort_gcm('physiq 1772','options iso incompatibles',1)
1401	endif
1402	#endif
1403	! #ifdef ISO
1404
1405	#ifdef ISO
1406	! initialisations isotopiques
1407	#ifdef ISOVERIF
1408	write(,) 'physiq 1366: call iso_init'
1409	write(,) 'ok_isotopes=',ok_isotopes
1410	#endif
1411	if (ok_isotopes) then
1412	call iso_init()
1413	endif
1414	#ifdef ISOTRAC
1415	if (ok_isotrac) then
1416	write(,) 'physiq 1416: call iso_traceurs_init'
1417	call iso_traceurs_init()
1418	endif
1419	#endif
1420	!write(,) 'gcm 265: ntraciso=',ntraciso
1421	#ifdef ISOVERIF
1422	write(,) 'physiq 1421: call iso_verif_init'
1423	call iso_verif_init()
1424	#endif
1425	#endif
1426
1427	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1428	!! Un petit travail \`a faire ici.
1429	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1430
1431	if (iflag_pbl>1) then
1432	PRINT*, "Using method MELLOR&YAMADA"
1433	endif
1434
1435	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1436	! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans
1437	! phylmd plutot que dyn3d
1438	! Attention : la version precedente n'etait pas tres propre.
1439	! Il se peut qu'il faille prendre une valeur differente de nbapp_rad
1440	! pour obtenir le meme resultat.
1441	dtime=pdtphys
1442	IF (MOD(INT(86400./dtime),nbapp_rad).EQ.0) THEN
1443	radpas = NINT( 86400./dtime/nbapp_rad)
1444	ELSE
1445	WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', &
1446	'multiple de nbapp_rad'
1447	WRITE(lunout,*) 'changer nbapp_rad ou alors commenter ce test ', &
1448	'mais 1+1<>2'
1449	abort_message='nbre de pas de temps physique n est pas multiple ' &
1450	// 'de nbapp_rad'
1451	call abort_physic(modname,abort_message,1)
1452	ENDIF
1453	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1454
1455	CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0)
1456	!jyg<
1457	IF (klon_glo==1) THEN
1458	pbl_tke(:,:,is_ave) = 0.
1459	DO nsrf=1,nbsrf
1460	DO k = 1,klev+1
1461	pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) &
1462	+pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
1463	ENDDO
1464	ENDDO
1465	!>jyg
1466	ENDIF
1467	!IM begin
1468	print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1) &
1469	,ratqs(1,1)
1470	!IM end
1471
1472	#ifdef ISO
1473	#ifdef ISOTRAC
1474	! on initialise les cartes des bassins pour les traceurs si besoin:
1475	call initialise_bassins_boites(presnivs)
1476	#endif
1477	#endif
1478
1479	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1480	!
1481	! on remet le calendrier a zero
1482	!
1483	IF (raz_date .eq. 1) THEN
1484	itau_phy = 0
1485	ENDIF
1486
1487	CALL printflag( tabcntr0,radpas,ok_journe, &
1488	ok_instan, ok_region )
1489	!
1490	IF (ABS(dtime-pdtphys).GT.0.001) THEN
1491	WRITE(lunout,*) 'Pas physique n est pas correct',dtime, &
1492	pdtphys
1493	abort_message='Pas physique n est pas correct '
1494	! call abort_physic(modname,abort_message,1)
1495	dtime=pdtphys
1496	ENDIF
1497	IF (nlon .NE. klon) THEN
1498	WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, &
1499	klon
1500	abort_message='nlon et klon ne sont pas coherents'
1501	call abort_physic(modname,abort_message,1)
1502	ENDIF
1503	IF (nlev .NE. klev) THEN
1504	WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev, &
1505	klev
1506	abort_message='nlev et klev ne sont pas coherents'
1507	call abort_physic(modname,abort_message,1)
1508	ENDIF
1509	!
1510	IF (dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN
1511	WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
1512	WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
1513	abort_message='Nbre d appels au rayonnement insuffisant'
1514	call abort_physic(modname,abort_message,1)
1515	ENDIF
1516	WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
1517	WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=", &
1518	ok_cvl
1519	!
1520	!KE43
1521	! Initialisation pour la convection de K.E. (sb):
1522	IF (iflag_con.GE.3) THEN
1523
1524	WRITE(lunout,)"** Convection de Kerry Emanuel 4.3 "
1525	WRITE(lunout,*) &
1526	"On va utiliser le melange convectif des traceurs qui"
1527	WRITE(lunout,*)"est calcule dans convect4.3"
1528	WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
1529
1530	DO i = 1, klon
1531	ema_cbmf(i) = 0.
1532	ema_pcb(i) = 0.
1533	ema_pct(i) = 0.
1534	! ema_workcbmf(i) = 0.
1535	ENDDO
1536	!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
1537	DO i = 1, klon
1538	ibas_con(i) = 1
1539	itop_con(i) = 1
1540	ENDDO
1541	!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
1542	!================================================================
1543	!CR:04.12.07: initialisations poches froides
1544	! Controle de ALE et ALP pour la fermeture convective (jyg)
1545	if (iflag_wake>=1) then
1546	CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr &
1547	,alp_bl_prescr, ale_bl_prescr)
1548	! 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU)
1549	! print*,'apres ini_wake iflag_cld_th=', iflag_cld_th
1550	endif
1551
1552	! do i = 1,klon
1553	! Ale_bl(i)=0.
1554	! Alp_bl(i)=0.
1555	! enddo
1556
1557	!===================================================================
1558	!IM stations CFMIP
1559	nCFMIP=npCFMIP
1560	OPEN(98,file='npCFMIP_param.data',status='old', &
1561	form='formatted',iostat=iostat)
1562	if (iostat == 0) then
1563	READ(98,*,end=998) nCFMIP
1564	998 CONTINUE
1565	CLOSE(98)
1566	CONTINUE
1567	IF(nCFMIP.GT.npCFMIP) THEN
1568	print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler'
1569	call abort_physic("physiq", "", 1)
1570	else
1571	print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP
1572	ENDIF
1573
1574	!
1575	ALLOCATE(tabCFMIP(nCFMIP))
1576	ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP))
1577	ALLOCATE(tabijGCM(nCFMIP))
1578	ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP))
1579	ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP))
1580	!
1581	! lecture des nCFMIP stations CFMIP, de leur numero
1582	! et des coordonnees geographiques lonCFMIP, latCFMIP
1583	!
1584	CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, &
1585	lonCFMIP, latCFMIP)
1586	!
1587	! identification des
1588	! 1) coordonnees lonGCM, latGCM des points CFMIP dans la
1589	! grille de LMDZ
1590	! 2) indices points tabijGCM de la grille physique 1d sur
1591	! klon points
1592	! 3) indices iGCM, jGCM de la grille physique 2d
1593	!
1594	CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, &
1595	tabijGCM, lonGCM, latGCM, iGCM, jGCM)
1596	!
1597	else
1598	ALLOCATE(tabijGCM(0))
1599	ALLOCATE(lonGCM(0), latGCM(0))
1600	ALLOCATE(iGCM(0), jGCM(0))
1601	end if
1602	else
1603	ALLOCATE(tabijGCM(0))
1604	ALLOCATE(lonGCM(0), latGCM(0))
1605	ALLOCATE(iGCM(0), jGCM(0))
1606	ENDIF
1607
1608	DO i=1,klon
1609	rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
1610	ENDDO
1611
1612	!34EK
1613	IF (ok_orodr) THEN
1614
1615	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1616	! FH sans doute a enlever de finitivement ou, si on le
1617	! garde, l'activer justement quand ok_orodr = false.
1618	! ce rugoro est utilise par la couche limite et fait double emploi
1619	! avec les param\'etrisations sp\'ecifiques de Francois Lott.
1620	! DO i=1,klon
1621	! rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
1622	! ENDDO
1623	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1624	IF (ok_strato) THEN
1625	CALL SUGWD_strato(klon,klev,paprs,pplay)
1626	ELSE
1627	CALL SUGWD(klon,klev,paprs,pplay)
1628	ENDIF
1629
1630	DO i=1,klon
1631	zuthe(i)=0.
1632	zvthe(i)=0.
1633	if(zstd(i).gt.10.)then
1634	zuthe(i)=(1.-zgam(i))*cos(zthe(i))
1635	zvthe(i)=(1.-zgam(i))*sin(zthe(i))
1636	endif
1637	ENDDO
1638	ENDIF
1639	!
1640	!
1641	lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours
1642	WRITE(lunout,*)'La frequence de lecture surface est de ', &
1643	lmt_pas
1644	!
1645	capemaxcels = 't_max(X)'
1646	t2mincels = 't_min(X)'
1647	t2maxcels = 't_max(X)'
1648	tinst = 'inst(X)'
1649	tave = 'ave(X)'
1650	!IM cf. AM 081204 BEG
1651	write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
1652	!IM cf. AM 081204 END
1653	!
1654	!=============================================================
1655	! Initialisation des sorties
1656	!=============================================================
1657
1658	#ifdef CPP_IOIPSL
1659
1660	!$OMP MASTER
1661	! FH : if ok_sync=.true. , the time axis is written at each time step
1662	! in the output files. Only at the end in the opposite case
1663	ok_sync_omp=.false.
1664	CALL getin('ok_sync',ok_sync_omp)
1665	call phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, &
1666	iGCM,jGCM,lonGCM,latGCM, &
1667	jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, &
1668	type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, &
1669	ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, &
1670	read_climoz, phys_out_filestations, &
1671	new_aod, aerosol_couple, &
1672	flag_aerosol_strat, pdtphys, paprs, pphis, &
1673	pplay, lmax_th, ptconv, ptconvth, ivap, &
1674	d_t, qx, d_qx, zmasse, ok_sync_omp)
1675	!$OMP END MASTER
1676	!$OMP BARRIER
1677	ok_sync=ok_sync_omp
1678
1679	freq_outNMC(1) = ecrit_files(7)
1680	freq_outNMC(2) = ecrit_files(8)
1681	freq_outNMC(3) = ecrit_files(9)
1682	WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1)
1683	WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2)
1684	WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3)
1685
1686	include "ini_histday_seri.h"
1687
1688	CALL ini_paramLMDZ_phy(dtime,nid_ctesGCM)
1689
1690	#endif
1691	ecrit_reg = ecrit_reg * un_jour
1692	ecrit_tra = ecrit_tra * un_jour
1693
1694	!XXXPB Positionner date0 pour initialisation de ORCHIDEE
1695	date0 = jD_ref
1696	WRITE(,) 'physiq date0 : ',date0
1697	!
1698	!
1699	!
1700	! Prescrire l'ozone dans l'atmosphere
1701	!
1702	!
1703	!c DO i = 1, klon
1704	!c DO k = 1, klev
1705	!c CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
1706	!c ENDDO
1707	!c ENDDO
1708	!
1709	IF (type_trac == 'inca') THEN
1710	#ifdef INCA
1711	CALL VTe(VTphysiq)
1712	CALL VTb(VTinca)
1713	calday = REAL(days_elapsed) + jH_cur
1714	WRITE(lunout,*) 'initial time chemini', days_elapsed, calday
1715
1716	CALL chemini( &
1717	rg, &
1718	ra, &
1719	cell_area, &
1720	latitude_deg, &
1721	longitude_deg, &
1722	presnivs, &
1723	calday, &
1724	klon, &
1725	nqtot, &
1726	nqo, &
1727	pdtphys, &
1728	annee_ref, &
1729	day_ref, &
1730	day_ini, &
1731	start_time, &
1732	itau_phy, &
1733	io_lon, &
1734	io_lat)
1735
1736	CALL VTe(VTinca)
1737	CALL VTb(VTphysiq)
1738	#endif
1739	END IF
1740
1741	!
1742	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1743	! Nouvelle initialisation pour le rayonnement RRTM
1744	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1745
1746	call iniradia(klon,klev,paprs(1,1:klev+1))
1747
1748	!$omp single
1749	if (read_climoz >= 1) then
1750	call open_climoz(ncid_climoz, press_climoz)
1751	END IF
1752	!$omp end single
1753	!
1754	!IM betaCRF
1755	pfree=70000. !Pa
1756	beta_pbl=1.
1757	beta_free=1.
1758	lon1_beta=-180.
1759	lon2_beta=+180.
1760	lat1_beta=90.
1761	lat2_beta=-90.
1762	mskocean_beta=.FALSE.
1763
1764	!albedo SB >>>
1765	select case(nsw)
1766	case(2)
1767	SFRWL(1)=0.45538747
1768	SFRWL(2)=0.54461211
1769	case(4)
1770	SFRWL(1)=0.45538747
1771	SFRWL(2)=0.32870591
1772	SFRWL(3)=0.18568763
1773	SFRWL(4)=3.02191470E-02
1774	case(6)
1775	SFRWL(1)=1.28432794E-03
1776	SFRWL(2)=0.12304168
1777	SFRWL(3)=0.33106142
1778	SFRWL(4)=0.32870591
1779	SFRWL(5)=0.18568763
1780	SFRWL(6)=3.02191470E-02
1781	end select
1782
1783
1784	!albedo SB <<<
1785
1786	OPEN(99,file='beta_crf.data',status='old', &
1787	form='formatted',err=9999)
1788	READ(99,*,end=9998) pfree
1789	READ(99,*,end=9998) beta_pbl
1790	READ(99,*,end=9998) beta_free
1791	READ(99,*,end=9998) lon1_beta
1792	READ(99,*,end=9998) lon2_beta
1793	READ(99,*,end=9998) lat1_beta
1794	READ(99,*,end=9998) lat2_beta
1795	READ(99,*,end=9998) mskocean_beta
1796	9998 Continue
1797	CLOSE(99)
1798	9999 Continue
1799	WRITE(,)'pfree=',pfree
1800	WRITE(,)'beta_pbl=',beta_pbl
1801	WRITE(,)'beta_free=',beta_free
1802	WRITE(,)'lon1_beta=',lon1_beta
1803	WRITE(,)'lon2_beta=',lon2_beta
1804	WRITE(,)'lat1_beta=',lat1_beta
1805	WRITE(,)'lat2_beta=',lat2_beta
1806	WRITE(,)'mskocean_beta=',mskocean_beta
1807	ENDIF
1808	!
1809	! ************** Fin de IF ( debut ) *************
1810	!
1811	!
1812	! Incrementer le compteur de la physique
1813	!
1814	itap = itap + 1
1815	!
1816	!
1817	! Update fraction of the sub-surfaces (pctsrf) and
1818	! initialize, where a new fraction has appeared, all variables depending
1819	! on the surface fraction.
1820	!
1821	CALL change_srf_frac(itap, dtime, days_elapsed+1, &
1822	pctsrf, fevap, z0m, z0h, agesno, &
1823	falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke &
1824	#ifdef ISO
1825	,fxtevap &
1826	#endif
1827	& )
1828
1829	! Update time and other variables in Reprobus
1830	IF (type_trac == 'repr') THEN
1831	#ifdef REPROBUS
1832	CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref)
1833	print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref
1834	CALL Rtime(debut)
1835	#endif
1836	END IF
1837
1838
1839	! Tendances bidons pour les processus qui n'affectent pas certaines
1840	! variables.
1841	du0(:,:)=0.
1842	dv0(:,:)=0.
1843	dt0 = 0.
1844	dq0(:,:)=0.
1845	dql0(:,:)=0.
1846	dqi0(:,:)=0.
1847	#ifdef ISO
1848	dxt0(:,:,:)=0.
1849	dxtl0(:,:,:)=0.
1850	dxti0(:,:,:)=0.
1851	#endif
1852	!
1853	! Mettre a zero des variables de sortie (pour securite)
1854	!
1855	DO i = 1, klon
1856	d_ps(i) = 0.0
1857	ENDDO
1858	DO k = 1, klev
1859	DO i = 1, klon
1860	d_t(i,k) = 0.0
1861	d_u(i,k) = 0.0
1862	d_v(i,k) = 0.0
1863	ENDDO
1864	ENDDO
1865	DO iq = 1, nqtot
1866	DO k = 1, klev
1867	DO i = 1, klon
1868	d_qx(i,k,iq) = 0.0
1869	ENDDO
1870	ENDDO
1871	ENDDO
1872	da(:,:)=0.
1873	mp(:,:)=0.
1874	phi(:,:,:)=0.
1875	! RomP >>>
1876	phi2(:,:,:)=0.
1877	beta_prec_fisrt(:,:)=0.
1878	beta_prec(:,:)=0.
1879	epmlmMm(:,:,:)=0.
1880	eplaMm(:,:)=0.
1881	d1a(:,:)=0.
1882	dam(:,:)=0.
1883	pmflxr=0.
1884	pmflxs=0.
1885	! RomP <<<
1886
1887	!
1888	! Ne pas affecter les valeurs entrees de u, v, h, et q
1889	!
1890	DO k = 1, klev
1891	DO i = 1, klon
1892	t_seri(i,k) = t(i,k)
1893	u_seri(i,k) = u(i,k)
1894	v_seri(i,k) = v(i,k)
1895	q_seri(i,k) = qx(i,k,ivap)
1896	ql_seri(i,k) = qx(i,k,iliq)
1897	!CR: ATTENTION, on rajoute la variable glace
1898	if (nqo.eq.2) then
1899	qs_seri(i,k) = 0.
1900	else if (nqo.eq.3) then
1901	qs_seri(i,k) = qx(i,k,isol)
1902	endif
1903	ENDDO
1904	ENDDO
1905
1906	! C Risi: dispatcher les isotopes dans les xt_seri
1907	#ifdef ISO
1908	#ifdef ISOVERIF
1909	write(,) 'physiq 1847: qx(1,1,:)=',qx(1,1,:)
1910	write(,) 'physiq 1846: ok_isotopes,ntraciso,niso=',ok_isotopes,ntraciso,niso
1911	#endif
1912	do ixt=1,ntraciso
1913	#ifdef ISOVERIF
1914	write(,) 'physiq tmp 1762a: ixt,iqiso_vap=',ixt,iqiso(ixt,ivap)
1915	write(,) 'physiq tmp 1762b: ixt,iqiso_liq=',ixt,iqiso(ixt,iliq)
1916	if (nqo.eq.3) then
1917	write(,) 'physiq tmp 1762c: ixt,iqiso_liq=',ixt,iqiso(ixt,iliq)
1918	endif !if (nqo.eq.3) then
1919	#endif
1920	if (ixt.gt.niso) then
1921	write(,) 'izone,iiso=',zone_num(iqiso(ixt,ivap)),iso_indnum(iqiso(ixt,ivap))
1922	endif
1923	DO k = 1, klev
1924	DO i = 1, klon
1925	xt_seri(ixt,i,k) = qx(i,k,iqiso(ixt,ivap))
1926	xtl_seri(ixt,i,k) = qx(i,k,iqiso(ixt,iliq))
1927	if (nqo.eq.2) then
1928	xts_seri(ixt,i,k) = 0.
1929	else if (nqo.eq.3) then
1930	xts_seri(ixt,i,k) = qx(i,k,iqiso(ixt,isol))
1931	endif
1932	enddo !DO i = 1, klon
1933	enddo ! DO k = 1, klev
1934	!write(,) 'physiq tmp 1897: dispatch termine pour ixt=',ixt
1935	enddo !do ixt=1,niso
1936	! write(,) 'physiq tmp 1898: dispatch termine pour tous'
1937	#endif
1938	! #ifdef ISO
1939
1940	!
1941	!--OB mass fixer
1942	IF (mass_fixer) THEN
1943	!--store initial water burden
1944	qql1(:)=0.0
1945	DO k = 1, klev
1946	qql1(:)=qql1(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k))*zmasse(:,k)
1947	ENDDO
1948	#ifdef ISO
1949	#ifdef ISOVERIF
1950	write(,) 'physiq tmp 1913'
1951	#endif
1952	do ixt=1,ntraciso
1953	xtql1(ixt,:)=0.0
1954	DO k = 1, klev
1955	xtql1(ixt,:)=xtql1(ixt,:)+(xt_seri(ixt,:,k)+xtl_seri(ixt,:,k)+xts_seri(ixt,:,k))*zmasse(:,k)
1956	ENDDO
1957	enddo !do ixt=1,ntraciso
1958	#endif
1959	ENDIF
1960	!--fin mass fixer
1961
1962	tke0(:,:)=pbl_tke(:,:,is_ave)
1963
1964	!CR:Nombre de traceurs de l'eau: nqo
1965	! IF (nqtot.GE.3) THEN
1966	IF (nqtot.GE.(nqo+1)) THEN
1967	! DO iq = 3, nqtot
1968	#ifdef ISO
1969	! les isotopes ne sont pas dispatchés dans tr_seri, il faut les enlever.
1970	! on a prévu pour ça un tableau d'indice dans infotrac
1971	#ifdef ISOVERIF
1972	write(,) 'physiq 1971: nqtottr=',nqtottr
1973	#endif
1974	do itr=1,nqtottr
1975	iq=itr_indice(itr)
1976	#ifdef ISOVERIF
1977	write(,) 'physiq 1973: itr,iq=',itr,iq
1978	write(,) 'qx(1,1,iq)=',qx(1,1,iq)
1979	#endif
1980	DO k = 1, klev
1981	DO i = 1, klon
1982	tr_seri(i,k,itr) = qx(i,k,iq) ! modif C Risi
1983	ENDDO
1984	ENDDO !DO k = 1, klev
1985	!write(,) 'physiq 1980'
1986	enddo !do itr=1,nqtottr
1987	#else
1988	DO iq = nqo+1, nqtot
1989	itr=iq-nqo
1990	DO k = 1, klev
1991	DO i = 1, klon
1992	tr_seri(i,k,itr) = qx(i,k,iq) ! modif C Risi
1993	!! tr_seri(i,k,iq-2) = qx(i,k,iq)
1994	! tr_seri(i,k,iq-nqo) = qx(i,k,iq)
1995	ENDDO
1996	ENDDO !DO k = 1, klev
1997	! write(,) 'physiq tmp 1959'
1998	ENDDO !DO iq = nqo+1, nqtot
1999	#endif
2000	ELSE !IF (nqtot.GE.(nqo+1)) THEN
2001	DO k = 1, klev
2002	DO i = 1, klon
2003	tr_seri(i,k,1) = 0.0
2004	ENDDO
2005	ENDDO
2006	ENDIF
2007	write(,) 'physiq tmp 1968'
2008	!
2009	DO i = 1, klon
2010	ztsol(i) = 0.
2011	ENDDO
2012	DO nsrf = 1, nbsrf
2013	DO i = 1, klon
2014	ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
2015	ENDDO
2016	ENDDO
2017	! write(,) 'physiq tmp 1979'
2018	! Initialize variables used for diagnostic purpose
2019	if (flag_inhib_tend .ne. 0) call init_cmp_seri
2020	! write(,) 'physiq tmp 1982: ip_ebil_phy=',ip_ebil_phy
2021	!IM
2022	IF (ip_ebil_phy.ge.1) THEN
2023	ztit='after dynamic'
2024	CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime &
2025	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
2026	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
2027	!#ifdef ISO
2028	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
2029	!#endif
2030	& )
2031
2032	#ifdef ISOVERIF
2033	call iso_verif_positif_choix_vect(t_seri(1,1),klev*klon,-100.0, &
2034	& 'physiq 2024, avant revaptot')
2035	#endif
2036	! Comme les tendances de la physique sont ajoute dans la dynamique,
2037	! on devrait avoir que la variation d'entalpie par la dynamique
2038	! est egale a la variation de la physique au pas de temps precedent.
2039	! Donc la somme de ces 2 variations devrait etre nulle.
2040	call diagphy(cell_area,ztit,ip_ebil_phy &
2041	, zero_v, zero_v, zero_v, zero_v, zero_v &
2042	, zero_v, zero_v, zero_v, ztsol &
2043	, d_h_vcol+d_h_vcol_phy, d_qt, 0. &
2044	, fs_bound, fq_bound )
2045	END IF
2046
2047	! Diagnostiquer la tendance dynamique
2048	#ifdef ISOVERIF
2049	write(,) 'physiq tmp 2010: ancien_ok=',ancien_ok
2050	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2051	do i=1,klon
2052	do k=1,klev
2053	if (q_seri(i,k).gt.ridicule) then
2054	if (iso_verif_o18_aberrant_nostop( &
2055	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
2056	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
2057	& 'physiq 2099 qv').eq.1) then
2058	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
2059	stop
2060	endif ! if (iso_verif_o18_aberrant_nostop
2061	endif !if (q_seri(i,k).gt.errmax) then
2062	if (ql_seri(i,k).gt.ridicule) then
2063	if (iso_verif_o18_aberrant_nostop( &
2064	& xtl_seri(iso_HDO,i,k)/ql_seri(i,k), &
2065	& xtl_seri(iso_O18,i,k)/ql_seri(i,k), &
2066	& 'physiq 2099 ql').eq.1) then
2067	write(,) 'i,k,ql_seri(i,k)=',i,k,ql_seri(i,k)
2068	stop
2069	endif ! if (iso_verif_o18_aberrant_nostop
2070	endif !if (q_seri(i,k).gt.errmax) then
2071	if (qs_seri(i,k).gt.ridicule) then
2072	if (iso_verif_o18_aberrant_nostop( &
2073	& xts_seri(iso_HDO,i,k)/qs_seri(i,k), &
2074	& xts_seri(iso_O18,i,k)/qs_seri(i,k), &
2075	& 'physiq 2099 qs').eq.1) then
2076	write(,) 'i,k,qs_seri(i,k)=',i,k,qs_seri(i,k)
2077	stop
2078	endif ! if (iso_verif_o18_aberrant_nostop
2079	endif !if (q_seri(i,k).gt.errmax) then
2080	enddo !k=1,klev
2081	enddo !i=1,klon
2082	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2083	#endif
2084	!
2085	IF (ancien_ok) THEN
2086	!
2087	d_u_dyn(:,:) = (u_seri(:,:)-u_ancien(:,:))/dtime
2088	d_v_dyn(:,:) = (v_seri(:,:)-v_ancien(:,:))/dtime
2089	d_t_dyn(:,:) = (t_seri(:,:)-t_ancien(:,:))/dtime
2090	d_q_dyn(:,:) = (q_seri(:,:)-q_ancien(:,:))/dtime
2091	d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/dtime
2092	d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/dtime
2093	CALL water_int(klon,klev,q_seri,zmasse,zx_tmp_fi2d)
2094	d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/dtime
2095	CALL water_int(klon,klev,ql_seri,zmasse,zx_tmp_fi2d)
2096	d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/dtime
2097	CALL water_int(klon,klev,qs_seri,zmasse,zx_tmp_fi2d)
2098	d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/dtime
2099	! !! RomP >>> td dyn traceur
2100	!write(,) 'physiq tmp 2096'
2101	IF (nqtot.GT.nqo) THEN ! jyg
2102	#ifdef ISO
2103	DO itr=1,nqtottr
2104	!iq=itr_indice(itr)
2105	d_tr_dyn(:,:,itr)=(tr_seri(:,:,itr)-tr_ancien(:,:,itr))/dtime
2106	ENDDO !DO itr=1,nqtottr
2107	#else
2108	DO iq = nqo+1, nqtot ! jyg
2109	d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/dtime ! jyg
2110	ENDDO !DO iq = nqo+1, nqtot
2111	#endif
2112	ENDIF
2113	! !! RomP <<<
2114
2115	#ifdef ISO
2116	! write(,) 'physiq tmp 2112'
2117	DO k = 1, klev
2118	DO i = 1, klon
2119	do ixt=1,ntraciso
2120	d_xt_dyn(ixt,i,k) = &
2121	& (xt_seri(ixt,i,k)-xt_ancien(ixt,i,k))/dtime
2122	d_xtl_dyn(ixt,i,k) = &
2123	& (xtl_seri(ixt,i,k)-xtl_ancien(ixt,i,k))/dtime
2124	d_xts_dyn(ixt,i,k) = &
2125	& (xts_seri(ixt,i,k)-xts_ancien(ixt,i,k))/dtime
2126	enddo ! do ixt=1,niso
2127	ENDDO
2128	ENDDO
2129	#ifdef ISOVERIF
2130	DO k = 1, klev
2131	DO i = 1, klon
2132	do ixt=1,ntraciso
2133	call iso_verif_noNaN(xt_seri(ixt,i,k),'physiq 2220')
2134	call iso_verif_noNaN(xtl_seri(ixt,i,k),'physiq 2220b')
2135	call iso_verif_noNaN(xts_seri(ixt,i,k),'physiq 2220b')
2136	call iso_verif_noNaN(d_xt_dyn(ixt,i,k),'physiq 2220c')
2137	call iso_verif_noNaN(d_xtl_dyn(ixt,i,k),'physiq 2220d')
2138	call iso_verif_noNaN(d_xts_dyn(ixt,i,k),'physiq 2220e')
2139	enddo ! do ixt=1,niso
2140	enddo
2141	enddo
2142	#endif
2143	#ifdef ISOVERIF
2144	if (iso_eau.gt.0) then
2145	DO k = 1, klev
2146	DO i = 1, klon
2147	call iso_verif_egalite_choix(xt_seri(iso_eau,i,k), &
2148	& q_seri(i,k),'physiq 2033a',errmax,errmaxrel)
2149	call iso_verif_egalite_choix(xtl_seri(iso_eau,i,k), &
2150	& ql_seri(i,k),'physiq 2033al',errmax,errmaxrel)
2151	call iso_verif_egalite_choix(xts_seri(iso_eau,i,k), &
2152	& qs_seri(i,k),'physiq 2033as',errmax,errmaxrel)
2153	call iso_verif_egalite_choix(xt_ancien(iso_eau,i,k), &
2154	& q_ancien(i,k),'physiq 2033b',errmax,errmaxrel)
2155	call iso_verif_egalite_choix(d_xt_dyn(iso_eau,i,k), &
2156	& d_q_dyn(i,k),'physiq 2033c',errmax,errmaxrel)
2157	enddo
2158	enddo
2159	endif
2160	if (iso_HDO.gt.0) then
2161	DO k = 1, klev
2162	DO i = 1, klon
2163	if (q_seri(i,k).gt.3e-3) then
2164	call iso_verif_positif(deltaD(xt_seri(iso_eau,i,k) &
2165	& /q_seri(i,k))+400.0,'physiq 2045a')
2166	call iso_verif_positif(deltaD(xt_ancien(iso_eau,i,k) &
2167	& /q_ancien(i,k))+400.0,'physiq 2045b')
2168	call iso_verif_egalite_choix(d_xt_dyn(iso_hdo,i,k) &
2169	& /tnat(iso_hdo),d_q_dyn(i,k),'physiq 2045c',1e-7,0.4)
2170	endif
2171	enddo
2172	enddo
2173	endif
2174	#ifdef ISOTRAC
2175	DO k = 1, klev
2176	DO i = 1, klon
2177	call iso_verif_traceur(xt_seri(1,i,k),'physiq 2065')
2178	call iso_verif_traceur(xt_ancien(1,i,k),'physiq 2066')
2179	enddo
2180	enddo
2181	#endif
2182	#endif
2183	#endif
2184
2185	ELSE ! ancien_OK
2186	! write(,) 'physiq tmp 2103'
2187	d_u_dyn(:,:) = 0.0
2188	d_v_dyn(:,:) = 0.0
2189	d_t_dyn(:,:) = 0.0
2190	d_q_dyn(:,:) = 0.0
2191	d_ql_dyn(:,:) = 0.0
2192	d_qs_dyn(:,:) = 0.0
2193	d_q_dyn2d(:) = 0.0
2194	d_ql_dyn2d(:) = 0.0
2195	d_qs_dyn2d(:) = 0.0
2196
2197	#ifdef ISO
2198	! write(,) 'physiq tmp 2115'
2199	! i=496
2200	! k=18
2201	! write(,) 'physiq 2105: q_seri(i,k),ql_seri(i,k),qs_seri(i,k),ridicule=', &
2202	! q_seri(i,k),ql_seri(i,k),qs_seri(i,k),ridicule
2203	DO k = 1, klev
2204	DO i = 1, klon
2205	do ixt=1,ntraciso
2206	d_xt_dyn(ixt,i,k)= 0.0
2207	d_xtl_dyn(ixt,i,k)= 0.0
2208	d_xts_dyn(ixt,i,k)= 0.0
2209	enddo
2210	enddo
2211	enddo
2212	! write(,) 'physiq tmp 2125'
2213	#endif
2214	! !! RomP >>> td dyn traceur
2215	IF (nqtot.GT.nqo) THEN ! jyg
2216	#ifdef ISO
2217	DO itr=1,nqtottr
2218	!iq=itr_indice(itr)
2219	d_tr_dyn(:,:,itr)= 0.0
2220	ENDDO !DO itr=1,nqtottr
2221	#else
2222	DO iq = nqo+1, nqtot ! jyg
2223	d_tr_dyn(:,:,iq-nqo)= 0.0 ! jyg
2224	ENDDO
2225	#endif
2226	ENDIF
2227	! !! RomP <<<
2228	ancien_ok = .TRUE.
2229	ENDIF
2230	! write(,) 'physiq tmp 2136'
2231	!
2232	! Ajouter le geopotentiel du sol:
2233	!
2234	DO k = 1, klev
2235	DO i = 1, klon
2236	zphi(i,k) = pphi(i,k) + pphis(i)
2237	ENDDO
2238	ENDDO
2239	!
2240	! Verifier les temperatures
2241	!
2242	!IM BEG
2243	IF (check) THEN
2244	amn=MIN(ftsol(1,is_ter),1000.)
2245	amx=MAX(ftsol(1,is_ter),-1000.)
2246	DO i=2, klon
2247	amn=MIN(ftsol(i,is_ter),amn)
2248	amx=MAX(ftsol(i,is_ter),amx)
2249	ENDDO
2250	!
2251	PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
2252	ENDIF !(check) THEN
2253	!IM END
2254	!
2255	CALL hgardfou(t_seri,ftsol,'debutphy',abortphy)
2256	IF (abortphy==1) Print*,'ERROR ABORT hgardfou debutphy'
2257
2258	!
2259	!IM BEG
2260	IF (check) THEN
2261	amn=MIN(ftsol(1,is_ter),1000.)
2262	amx=MAX(ftsol(1,is_ter),-1000.)
2263	DO i=2, klon
2264	amn=MIN(ftsol(i,is_ter),amn)
2265	amx=MAX(ftsol(i,is_ter),amx)
2266	ENDDO
2267	!
2268	PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
2269	ENDIF !(check) THEN
2270	!IM END
2271	!
2272	! Mettre en action les conditions aux limites (albedo, sst, etc.).
2273	! Prescrire l'ozone et calculer l'albedo sur l'ocean.
2274	!
2275	if (read_climoz >= 1) then
2276	! Ozone from a file
2277	! Update required ozone index:
2278	ro3i = int((days_elapsed + jh_cur - jh_1jan) / year_len * 360.) + 1
2279	if (ro3i == 361) ro3i = 360
2280	! (This should never occur, except perhaps because of roundup
2281	! error. See documentation.)
2282	if (ro3i /= co3i) then
2283	! Update ozone field:
2284	if (read_climoz == 1) then
2285	call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i, &
2286	press_in_edg=press_climoz, paprs=paprs, v3=wo)
2287	else
2288	! read_climoz == 2
2289	call regr_pr_av(ncid_climoz, (/"tro3 ", &
2290	"tro3_daylight"/), julien=ro3i, press_in_edg=press_climoz, &
2291	paprs=paprs, v3=wo)
2292	end if
2293	! Convert from mole fraction of ozone to column density of ozone in a
2294	! cell, in kDU:
2295	forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l) * rmo3 / rmd &
2296	* zmasse / dobson_u / 1e3
2297	! (By regridding ozone values for LMDZ only once every 360th of
2298	! year, we have already neglected the variation of pressure in one
2299	! 360th of year. So do not recompute "wo" at each time step even if
2300	! "zmasse" changes a little.)
2301	co3i = ro3i
2302	end if
2303	ELSEIF (MOD(itap-1,lmt_pas) == 0) THEN
2304	! Once per day, update ozone from Royer:
2305
2306	IF (solarlong0<-999.) then
2307	! Generic case with evolvoing season
2308	zzz=real(days_elapsed+1)
2309	ELSE IF (abs(solarlong0-1000.)<1.e-4) then
2310	! Particular case with annual mean insolation
2311	zzz=real(90) ! could be revisited
2312	IF (read_climoz/=-1) THEN
2313	abort_message ='read_climoz=-1 is recommended when ' &
2314	// 'solarlong0=1000.'
2315	CALL abort_physic (modname,abort_message,1)
2316	ENDIF
2317	ELSE
2318	! Case where the season is imposed with solarlong0
2319	zzz=real(90) ! could be revisited
2320	ENDIF
2321	wo(:,:,1)=ozonecm(latitude_deg, paprs,read_climoz,rjour=zzz)
2322	ENDIF
2323	!
2324	! Re-evaporer l'eau liquide nuageuse
2325	!
2326	DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse
2327	DO i = 1, klon
2328	zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
2329	!jyg<
2330	! Attention : Arnaud a propose des formules completement differentes
2331	! A verifier !!!
2332	zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
2333	IF (iflag_ice_thermo .EQ. 0) THEN
2334	zlsdcp=zlvdcp
2335	ENDIF
2336	!>jyg
2337
2338	!write(,) 'physiq tmp 2245: iflag_ice_thermo=',iflag_ice_thermo
2339	if (iflag_ice_thermo.eq.0) then
2340	!pas necessaire a priori
2341
2342	zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
2343	zb = MAX(0.0,ql_seri(i,k))
2344	za = - MAX(0.0,ql_seri(i,k)) &
2345	* (zlvdcp(1.-zdelta)+zlsdcpzdelta)
2346	t_seri(i,k) = t_seri(i,k) + za
2347	q_seri(i,k) = q_seri(i,k) + zb
2348	ql_seri(i,k) = 0.0
2349	d_t_eva(i,k) = za
2350	d_q_eva(i,k) = zb
2351
2352	#ifdef ISO
2353	!#ifdef ISOVERIF
2354	! write(,) 'physiq tmp 2239'
2355	!#endif
2356	! DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse
2357	! DO i = 1, klon
2358	do ixt=1,ntraciso
2359	zbxt = MAX(0.0,xtl_seri(ixt,i,k))
2360	xt_seri(ixt,i,k) = xt_seri(ixt,i,k) + zbxt
2361	xtl_seri(ixt,i,k) = 0.0
2362	d_xt_eva(ixt,i,k) = zbxt
2363	enddo ! do ixt=1,niso
2364	! ENDDO
2365	! ENDDO
2366	#ifdef ISOVERIF
2367	do ixt=1,ntraciso
2368	call iso_verif_noNaN(xt_seri(ixt,i,k), &
2369	& 'physiq 2417: apres evap tot')
2370	enddo
2371	if (iso_eau.gt.0) then
2372	! DO k = 1, klev
2373	! DO i = 1, klon
2374	call iso_verif_egalite_choix( &
2375	& xt_seri(iso_eau,i,k),q_seri(i,k), &
2376	& 'physiq 1891+, après réévap totale',errmax,errmaxrel)
2377	call iso_verif_egalite_choix( &
2378	& xtl_seri(iso_eau,i,k),ql_seri(i,k), &
2379	& 'physiq 2209+, après réévap totale',errmax,errmaxrel)
2380	! ENDDO ! DO i = 1, klon
2381	! ENDDO !DO k = 1, klev
2382	endif !if (iso_eau.gt.0) then
2383	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2384	if (q_seri(i,k).gt.ridicule) then
2385	if (iso_verif_o18_aberrant_nostop( &
2386	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
2387	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
2388	& 'physiq 2315: apres reevap totale').eq.1) then
2389	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
2390	write(,) 'd_q_eva(i,k)=',d_q_eva(i,k)
2391	write(,) 'deltaD(d_q_eva(i,k))=',deltaD(d_xt_eva(iso_HDO,i,k)/d_q_eva(i,k))
2392	write(,) 'deltaO18(d_q_eva(i,k))=',deltaO(d_xt_eva(iso_O18,i,k)/d_q_eva(i,k))
2393	stop
2394	endif ! if (iso_verif_o18_aberrant_nostop
2395	endif !if (q_seri(i,k).gt.errmax) then
2396	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2397	#ifdef ISOTRAC
2398	! DO k = 1, klev
2399	! DO i = 1, klon
2400	call iso_verif_traceur(xt_seri(1,i,k), &
2401	& 'physiq 2165')
2402	call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
2403	& 'physiq 2165b')
2404	! ENDDO ! DO i = 1, klon
2405	! ENDDO !DO k = 1, klev
2406	#endif
2407
2408	#endif
2409	#endif
2410
2411	else
2412
2413	!CR: on r\'e-\'evapore eau liquide et glace
2414
2415	! zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
2416	! zb = MAX(0.0,ql_seri(i,k))
2417	! za = - MAX(0.0,ql_seri(i,k)) &
2418	! * (zlvdcp(1.-zdelta)+zlsdcpzdelta)
2419	zb = MAX(0.0,ql_seri(i,k)+qs_seri(i,k))
2420	za = - MAX(0.0,ql_seri(i,k))*zlvdcp &
2421	- MAX(0.0,qs_seri(i,k))*zlsdcp
2422	t_seri(i,k) = t_seri(i,k) + za
2423	q_seri(i,k) = q_seri(i,k) + zb
2424	ql_seri(i,k) = 0.0
2425	!on \'evapore la glace
2426	qs_seri(i,k) = 0.0
2427	d_t_eva(i,k) = za
2428	d_q_eva(i,k) = zb
2429	endif
2430
2431	#ifdef ISO
2432	!#ifdef ISOVERIF
2433	! write(,) 'physiq tmp 2307'
2434	!#endif
2435	! DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse
2436	! DO i = 1, klon
2437	do ixt=1,ntraciso
2438	zbxt = MAX(0.0,xtl_seri(ixt,i,k)+xts_seri(ixt,i,k))
2439	xt_seri(ixt,i,k) = xt_seri(ixt,i,k) + zbxt
2440	xtl_seri(ixt,i,k) = 0.0
2441	xts_seri(ixt,i,k) = 0.0
2442	d_xt_eva(ixt,i,k) = zbxt
2443	enddo ! do ixt=1,niso
2444	! ENDDO
2445	! ENDDO
2446	#ifdef ISOVERIF
2447	do ixt=1,ntraciso
2448	call iso_verif_noNaN(xt_seri(ixt,i,k), &
2449	& 'physiq 2417: apres evap tot')
2450	enddo
2451
2452	#endif
2453	#ifdef ISOVERIF
2454	if (iso_eau.gt.0) then
2455	! DO k = 1, klev
2456	! DO i = 1, klon
2457	call iso_verif_egalite_choix( &
2458	& xt_seri(iso_eau,i,k),q_seri(i,k), &
2459	& 'physiq 1891, après réévap totale',errmax,errmaxrel)
2460	call iso_verif_egalite_choix( &
2461	& xtl_seri(iso_eau,i,k),ql_seri(i,k), &
2462	& 'physiq 2209, après réévap totale',errmax,errmaxrel)
2463	call iso_verif_egalite_choix( &
2464	& xts_seri(iso_eau,i,k),qs_seri(i,k), &
2465	& 'physiq 2209b, après réévap totale',errmax,errmaxrel)
2466	! ENDDO ! DO i = 1, klon
2467	! ENDDO !DO k = 1, klev
2468	! DO i = 1, klon
2469	call iso_verif_egalite_choix( &
2470	& xtsnow_fall(iso_eau,i),snow_fall(i), &
2471	& 'physiq 2276',errmax,errmaxrel)
2472	! enddo !DO i = 1, klon
2473	endif !if (iso_eau.gt.0) then
2474
2475	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2476	if (q_seri(i,k).gt.ridicule) then
2477	if (iso_verif_o18_aberrant_nostop( &
2478	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
2479	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
2480	& 'physiq 2408: apres reevap totale').eq.1) then
2481	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
2482	stop
2483	endif ! if (iso_verif_o18_aberrant_nostop
2484	endif !if (q_seri(i,k).gt.errmax) then
2485	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2486	#ifdef ISOTRAC
2487	! DO k = 1, klev
2488	! DO i = 1, klon
2489	call iso_verif_traceur(xt_seri(1,i,k), &
2490	& 'physiq 2165')
2491	call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
2492	& 'physiq 2165b')
2493	! ENDDO ! DO i = 1, klon
2494	! ENDDO !DO k = 1, klev
2495	#endif
2496	#endif
2497	#endif
2498
2499	ENDDO
2500	ENDDO
2501
2502	#ifdef ISO
2503	#ifdef ISOTRAC
2504	call isotrac_recolorise_general(xt_seri,t_seri,zx_rh,presnivs)
2505	#endif
2506	#endif
2507
2508	!IM
2509	IF (ip_ebil_phy.ge.2) THEN
2510	ztit='after reevap'
2511	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,1,dtime &
2512	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
2513	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
2514	!#ifdef ISO
2515	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
2516	!#endif
2517	& )
2518	call diagphy(cell_area,ztit,ip_ebil_phy &
2519	, zero_v, zero_v, zero_v, zero_v, zero_v &
2520	, zero_v, zero_v, zero_v, ztsol &
2521	, d_h_vcol, d_qt, d_ec &
2522	, fs_bound, fq_bound )
2523	!
2524	END IF
2525
2526	!
2527	!=========================================================================
2528	! Calculs de l'orbite.
2529	! Necessaires pour le rayonnement et la surface (calcul de l'albedo).
2530	! doit donc etre plac\'e avant radlwsw et pbl_surface
2531
2532	! !! jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2533	call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq)
2534	day_since_equinox = (jD_cur + jH_cur) - jD_eq
2535	!
2536	! choix entre calcul de la longitude solaire vraie ou valeur fixee a
2537	! solarlong0
2538	if (solarlong0<-999.) then
2539	if (new_orbit) then
2540	! calcul selon la routine utilisee pour les planetes
2541	call solarlong(day_since_equinox, zlongi, dist)
2542	else
2543	! calcul selon la routine utilisee pour l'AR4
2544	CALL orbite(REAL(days_elapsed+1),zlongi,dist)
2545	endif
2546	else
2547	zlongi=solarlong0 ! longitude solaire vraie
2548	dist=1. ! distance au soleil / moyenne
2549	endif
2550	if(prt_level.ge.1) &
2551	write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist
2552
2553
2554	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2555	! Calcul de l'ensoleillement :
2556	! ============================
2557	! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur
2558	! l'annee a partir d'une formule analytique.
2559	! Cet ensoleillement est sym\'etrique autour de l'\'equateur et
2560	! non nul aux poles.
2561	IF (abs(solarlong0-1000.)<1.e-4) then
2562	call zenang_an(iflag_cycle_diurne.GE.1,jH_cur, &
2563	latitude_deg,longitude_deg,rmu0,fract)
2564	JrNt = 1.0
2565	ELSE
2566	! recode par Olivier Boucher en sept 2015
2567	SELECT CASE (iflag_cycle_diurne)
2568	CASE(0)
2569	! Sans cycle diurne
2570	CALL angle(zlongi, latitude_deg, fract, rmu0)
2571	swradcorr = 1.0
2572	JrNt = 1.0
2573	zrmu0 = rmu0
2574	CASE(1)
2575	! Avec cycle diurne sans application des poids
2576	! bit comparable a l ancienne formulation cycle_diurne=true
2577	! on integre entre gmtime et gmtime+radpas
2578	zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s)
2579	CALL zenang(zlongi,jH_cur,0.0,zdtime, &
2580	latitude_deg,longitude_deg,rmu0,fract)
2581	zrmu0 = rmu0
2582	swradcorr = 1.0
2583	! Calcul du flag jour-nuit
2584	JrNt = 0.0
2585	WHERE (fract.GT.0.0) JrNt = 1.0
2586	CASE(2)
2587	! Avec cycle diurne sans application des poids
2588	! On integre entre gmtime-pdtphys et gmtime+pdtphys*(radpas-1)
2589	! Comme cette routine est appele a tous les pas de temps de
2590	! la physique meme si le rayonnement n'est pas appele je
2591	! remonte en arriere les radpas-1 pas de temps
2592	! suivant. Petite ruse avec MOD pour prendre en compte le
2593	! premier pas de temps de la physique pendant lequel
2594	! itaprad=0
2595	zdtime1=dtime*REAL(-MOD(itaprad,radpas)-1)
2596	zdtime2=dtime*REAL(radpas-MOD(itaprad,radpas)-1)
2597	CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
2598	latitude_deg,longitude_deg,rmu0,fract)
2599	!
2600	! Calcul des poids
2601	!
2602	zdtime1=-dtime !--on corrige le rayonnement pour representer le
2603	zdtime2=0.0 !--pas de temps de la physique qui se termine
2604	CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, &
2605	latitude_deg,longitude_deg,zrmu0,zfract)
2606	swradcorr = 0.0
2607	WHERE (rmu0.GE.1.e-10 .OR. fract.GE.1.e-10) &
2608	swradcorr=zfract/fract*zrmu0/rmu0
2609	! Calcul du flag jour-nuit
2610	JrNt = 0.0
2611	WHERE (zfract.GT.0.0) JrNt = 1.0
2612	END SELECT
2613	ENDIF
2614
2615	if (mydebug) then
2616	call writefield_phy('u_seri',u_seri,nbp_lev)
2617	call writefield_phy('v_seri',v_seri,nbp_lev)
2618	call writefield_phy('t_seri',t_seri,nbp_lev)
2619	call writefield_phy('q_seri',q_seri,nbp_lev)
2620	endif
2621
2622	!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
2623	! Appel au pbl_surface : Planetary Boudary Layer et Surface
2624	! Cela implique tous les interactions des sous-surfaces et la
2625	! partie diffusion turbulent du couche limit.
2626	!
2627	! Certains varibales de sorties de pbl_surface sont utiliser que pour
2628	! ecriture des fihiers hist_XXXX.nc, ces sont :
2629	! qsol, zq2m, s_pblh, s_lcl,
2630	! s_capCL, s_oliqCL, s_cteiCL,s_pblT,
2631	! s_therm, s_trmb1, s_trmb2, s_trmb3,
2632	! zu10m, zv10m, fder,
2633	! zxqsurf, rh2m, zxfluxu, zxfluxv,
2634	! frugs, agesno, fsollw, fsolsw,
2635	! d_ts, fevap, fluxlat, t2m,
2636	! wfbils, wfbilo, fluxt, fluxu, fluxv,
2637	!
2638	! Certains ne sont pas utiliser du tout :
2639	! dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
2640	!
2641
2642	! Calcul de l'humidite de saturation au niveau du sol
2643
2644
2645
2646	if (iflag_pbl/=0) then
2647
2648	!jyg+nrlmd<
2649	IF (prt_level .ge. 2 .and. mod(iflag_pbl_split,2) .eq. 1) THEN
2650	print *,'debut du splitting de la PBL'
2651	ENDIF
2652	! !!
2653	!=================================================================
2654	! PROVISOIRE : DECOUPLAGE PBL/WAKE
2655	! --------------------------------
2656	!
2657	!! wake_deltat_sav(:,:)=wake_deltat(:,:)
2658	!! wake_deltaq_sav(:,:)=wake_deltaq(:,:)
2659	!! wake_deltat(:,:)=0.
2660	!! wake_deltaq(:,:)=0.
2661	!=================================================================
2662	!>jyg+nrlmd
2663	!
2664	!-------gustiness calculation-------!
2665	IF (iflag_gusts==0) THEN
2666	gustiness(1:klon)=0
2667	ELSE IF (iflag_gusts==1) THEN
2668	do i = 1, klon
2669	gustiness(i)=f_gust_blale_bl(i)+f_gust_wkale_wake(i)
2670	enddo
2671	! ELSE IF (iflag_gusts==2) THEN
2672	! do i = 1, klon
2673	! gustiness(i)=f_gust_blale_bl(i)+sigma_wk(i)f_gust_wk&
2674	! *ale_wake(i) !! need to make sigma_wk accessible here
2675	! enddo
2676	! ELSE IF (iflag_gusts==3) THEN
2677	! do i = 1, klon
2678	! gustiness(i)=f_gust_blalp_bl(i)+f_gust_wkalp_wake(i)
2679	! enddo
2680	ENDIF
2681
2682	!write(,) 'physiq tmp 2674'
2683
2684	CALL pbl_surface( &
2685	dtime, date0, itap, days_elapsed+1, &
2686	debut, lafin, &
2687	longitude_deg, latitude_deg, rugoro, zrmu0, &
2688	zsig, sollwdown, pphi, cldt, &
2689	rain_fall, snow_fall, solsw, sollw, &
2690	gustiness, &
2691	t_seri, q_seri, u_seri, v_seri, &
2692	!nrlmd+jyg<
2693	wake_deltat, wake_deltaq, wake_cstar, wake_s, &
2694	!>nrlmd+jyg
2695	pplay, paprs, pctsrf, &
2696	ftsol,SFRWL,falb_dir,falb_dif,ustar,u10m,v10m,wstar, &
2697	!albedo SB <<<
2698	cdragh, cdragm, u1, v1, &
2699	!albedo SB >>>
2700	! albsol1, albsol2, sens, evap, &
2701	albsol_dir, albsol_dif, sens, evap, &
2702	!albedo SB <<<
2703	albsol3_lic,runoff, snowhgt, qsnow, to_ice, sissnow, &
2704	zxtsol, zxfluxlat, zt2m, qsat2m, &
2705	d_t_vdf, d_q_vdf, d_u_vdf, d_v_vdf, d_t_diss, &
2706	!nrlmd<
2707	!jyg<
2708	d_t_vdf_w, d_q_vdf_w, &
2709	d_t_vdf_x, d_q_vdf_x, &
2710	sens_x, zxfluxlat_x, sens_w, zxfluxlat_w, &
2711	!>jyg
2712	delta_tsurf,wake_dens, &
2713	cdragh_x,cdragh_w,cdragm_x,cdragm_w, &
2714	kh,kh_x,kh_w, &
2715	!>nrlmd
2716	coefh(1:klon,1:klev,1:nbsrf+1), coefm(1:klon,1:klev,1:nbsrf+1), &
2717	slab_wfbils, &
2718	qsol, zq2m, s_pblh, s_lcl, &
2719	!jyg<
2720	s_pblh_x, s_lcl_x, s_pblh_w, s_lcl_w, &
2721	!>jyg
2722	s_capCL, s_oliqCL, s_cteiCL,s_pblT, &
2723	s_therm, s_trmb1, s_trmb2, s_trmb3, &
2724	zustar, zu10m, zv10m, fder, &
2725	zxqsurf, rh2m, zxfluxu, zxfluxv, &
2726	z0m, z0h, agesno, fsollw, fsolsw, &
2727	d_ts, fevap, fluxlat, t2m, &
2728	wfbils, wfbilo, fluxt, fluxu, fluxv, &
2729	dsens, devap, zxsnow, &
2730	zxfluxt, zxfluxq, q2m, fluxq, pbl_tke, &
2731	!nrlmd+jyg<
2732	wake_delta_pbl_TKE &
2733	!>nrlmd+jyg
2734
2735	#ifdef ISO
2736	& ,xtrain_fall, xtsnow_fall,xt_seri, &
2737	& wake_deltaxt,xtevap,fxtevap, &
2738	& d_xt_vdf,d_xt_vdf_w,d_xt_vdf_x, &
2739	& xtsol,dxtevap,zxxtsnow,zxfluxxt,fluxxt, &
2740	& h1_diag,runoff_diag,xtrunoff_diag &
2741	#endif
2742	& )
2743
2744
2745	#ifdef ISO
2746	! write(,) 'physiq 2402: apres pbl_surface'
2747	#ifdef ISOVERIF
2748	do i=1,klon
2749	do k=1,klev
2750	do ixt=1,ntraciso
2751	call iso_verif_noNaN(d_xt_vdf(ixt,i,k),'physiq 1993a')
2752	call iso_verif_noNaN(xt_seri(ixt,i,k),'physiq 1993b')
2753	enddo !do ixt=1,niso
2754	enddo
2755	enddo
2756	#endif
2757	#ifdef ISOVERIF
2758	do i=1,klon
2759	do k=1,klev
2760	#ifdef ISOTRAC
2761	call iso_verif_traceur_justmass(d_xt_vdf(1,i,k),'physiq 2443')
2762	#endif
2763	enddo
2764	enddo
2765
2766	! verif iso_eau
2767	!write(,) 'physiq tmp 2748: iso_eau=',iso_eau
2768	!write(,) 'use_iso=',use_iso
2769	!write(,) 'iso_eau.gt.0=',iso_eau.gt.0
2770	!write(,) 'd_xt_vdf(iso_eau,1,1),d_q_vdf(1,1)=',d_xt_vdf(iso_eau,1,1),d_q_vdf(1,1)
2771	!write(,) 'bidouille_anti_divergence=',bidouille_anti_divergence
2772	if (iso_eau.gt.0) then
2773	! write(,) 'physiq 2665: d_q_vdf,d_xt_vdf(iso_eau,554,19)=',d_q_vdf(554,19),d_xt_vdf(iso_eau,554,19)
2774	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,2,1)=',d_q_vdf(2,1),d_xt_vdf(iso_eau,2,1)
2775	do i=1,klon
2776	! write(,) 'physiq 2667: i,k=',i,k
2777	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,554,19)=',d_q_vdf(554,19),d_xt_vdf(iso_eau,554,19)
2778	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,2,1)=',d_q_vdf(2,1),d_xt_vdf(iso_eau,2,1)
2779	do k=1,klev
2780	! write(,) 'physiq 2670: i,k=',i,k
2781	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,554,19)=',d_q_vdf(554,19),d_xt_vdf(iso_eau,554,19)
2782	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,2,1)=',d_q_vdf(2,1),d_xt_vdf(iso_eau,2,1)
2783	! write(,) 'd_q_vdf,d_xt_vdf(iso_eau,i,k)=',d_q_vdf(i,k),d_xt_vdf(iso_eau,i,k)
2784	call iso_verif_egalite_choix( &
2785	& d_xt_vdf(iso_eau,i,k),d_q_vdf(i,k), &
2786	& 'physiq 1984',errmax,errmaxrel)
2787	call iso_verif_egalite_choix( &
2788	& xt_seri(iso_eau,i,k),q_seri(i,k), &
2789	& 'physiq 1985',errmax,errmaxrel)
2790	do nsrf=1,nbsrf
2791	call iso_verif_egalite_choix(fluxxt(iso_eau,i,k,nsrf), &
2792	& fluxq(i,k,nsrf),'physiq 1991',errmax,errmaxrel)
2793	enddo !do nsrf=1,nbsrf
2794	enddo !k=1,klev
2795	enddo !i=1,klon
2796	endif !if (iso_eau.gt.0) then
2797	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2798	do i=1,klon
2799	do k=1,klev
2800	if (q_seri(i,k).gt.ridicule) then
2801	if (iso_verif_o18_aberrant_nostop( &
2802	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
2803	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
2804	& 'physiq 4177, apres pbl_surface').eq.1) then
2805	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
2806	stop
2807	endif ! if (iso_verif_o18_aberrant_nostop
2808	endif !if (q_seri(i,k).gt.errmax) then
2809	enddo !k=1,klev
2810	enddo !i=1,klon
2811	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
2812	!write(,) 'physiq tmp 2689'
2813	#endif
2814	!#ifdef ISOVERIF
2815	#endif
2816	!#ifdef ISO
2817	!
2818	!=================================================================
2819	! PROVISOIRE : DECOUPLAGE PBL/WAKE
2820	! --------------------------------
2821	!
2822	!! wake_deltat(:,:)=wake_deltat_sav(:,:)
2823	!! wake_deltaq(:,:)=wake_deltaq_sav(:,:)
2824	!=================================================================
2825	!
2826	! Add turbulent diffusion tendency to the wake difference variables
2827	IF (mod(iflag_pbl_split,2) .NE. 0) THEN
2828	wake_deltat(:,:) = wake_deltat(:,:) + (d_t_vdf_w(:,:)-d_t_vdf_x(:,:))
2829	wake_deltaq(:,:) = wake_deltaq(:,:) + (d_q_vdf_w(:,:)-d_q_vdf_x(:,:))
2830	#ifdef ISO
2831	do ixt=1,ntraciso
2832	wake_deltaxt(:,:,:) = wake_deltaxt(:,:,:) + (d_xt_vdf_w(:,:,:)-d_xt_vdf_x(:,:,:))
2833	enddo
2834	#endif
2835	ENDIF
2836
2837
2838	!---------------------------------------------------------------------
2839	! ajout des tendances de la diffusion turbulente
2840	IF (klon_glo==1) THEN
2841	CALL add_pbl_tend &
2842	(d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,&
2843	'vdf',abortphy,flag_inhib_tend &
2844	#ifdef ISO
2845	& ,d_xt_vdf,dxtl0,dxti0 &
2846	#endif
2847	& )
2848	ELSE
2849	CALL add_phys_tend &
2850	(d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,dqi0,paprs,&
2851	'vdf',abortphy,flag_inhib_tend &
2852	#ifdef ISO
2853	& ,d_xt_vdf,dxtl0,dxti0 &
2854	#endif
2855	& )
2856	ENDIF
2857
2858	#ifdef ISOVERIF
2859	write(,) 'physiq tmp 2736'
2860	#endif
2861	!--------------------------------------------------------------------
2862
2863	if (mydebug) then
2864	call writefield_phy('u_seri',u_seri,nbp_lev)
2865	call writefield_phy('v_seri',v_seri,nbp_lev)
2866	call writefield_phy('t_seri',t_seri,nbp_lev)
2867	call writefield_phy('q_seri',q_seri,nbp_lev)
2868	endif
2869
2870
2871	!albedo SB >>>
2872	albsol1=0.
2873	albsol2=0.
2874	falb1=0.
2875	falb2=0.
2876	select case(nsw)
2877	case(2)
2878	albsol1=albsol_dir(:,1)
2879	albsol2=albsol_dir(:,2)
2880	falb1=falb_dir(:,1,:)
2881	falb2=falb_dir(:,2,:)
2882	case(4)
2883	albsol1=albsol_dir(:,1)
2884	albsol2=albsol_dir(:,2)SFRWL(2)+albsol_dir(:,3)SFRWL(3) &
2885	+albsol_dir(:,4)*SFRWL(4)
2886	albsol2=albsol2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
2887	falb1=falb_dir(:,1,:)
2888	falb2=falb_dir(:,2,:)SFRWL(2)+falb_dir(:,3,:)SFRWL(3) &
2889	+falb_dir(:,4,:)*SFRWL(4)
2890	falb2=falb2/(SFRWL(2)+SFRWL(3)+SFRWL(4))
2891	case(6)
2892	albsol1=albsol_dir(:,1)SFRWL(1)+albsol_dir(:,2)SFRWL(2) &
2893	+albsol_dir(:,3)*SFRWL(3)
2894	albsol1=albsol1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
2895	albsol2=albsol_dir(:,4)SFRWL(4)+albsol_dir(:,5)SFRWL(5) &
2896	+albsol_dir(:,6)*SFRWL(6)
2897	albsol2=albsol2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
2898	falb1=falb_dir(:,1,:)SFRWL(1)+falb_dir(:,2,:)SFRWL(2) &
2899	+falb_dir(:,3,:)*SFRWL(3)
2900	falb1=falb1/(SFRWL(1)+SFRWL(2)+SFRWL(3))
2901	falb2=falb_dir(:,4,:)SFRWL(4)+falb_dir(:,5,:)SFRWL(5) &
2902	+falb_dir(:,6,:)*SFRWL(6)
2903	falb2=falb2/(SFRWL(4)+SFRWL(5)+SFRWL(6))
2904	end select
2905	!albedo SB <<<
2906
2907
2908	CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh, &
2909	t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot)
2910
2911
2912	IF (ip_ebil_phy.ge.2) THEN
2913	ztit='after surface_main'
2914	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
2915	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
2916	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
2917	!#ifdef ISO
2918	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
2919	!#endif
2920	& )
2921	call diagphy(cell_area,ztit,ip_ebil_phy &
2922	, zero_v, zero_v, zero_v, zero_v, sens &
2923	, evap , zero_v, zero_v, ztsol &
2924	, d_h_vcol, d_qt, d_ec &
2925	, fs_bound, fq_bound )
2926	END IF
2927
2928	ENDIF
2929	! =================================================================== c
2930	! Calcul de Qsat
2931
2932	DO k = 1, klev
2933	DO i = 1, klon
2934	zx_t = t_seri(i,k)
2935	IF (thermcep) THEN
2936	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
2937	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
2938	zx_qs = MIN(0.5,zx_qs)
2939	zcor = 1./(1.-retv*zx_qs)
2940	zx_qs = zx_qs*zcor
2941	ELSE
2942	!! IF (zx_t.LT.t_coup) THEN !jyg
2943	IF (zx_t.LT.rtt) THEN !jyg
2944	zx_qs = qsats(zx_t)/pplay(i,k)
2945	ELSE
2946	zx_qs = qsatl(zx_t)/pplay(i,k)
2947	ENDIF
2948	ENDIF
2949	zqsat(i,k)=zx_qs
2950	ENDDO
2951	ENDDO
2952
2953	if (prt_level.ge.1) then
2954	write(lunout,*) 'L qsat (g/kg) avant clouds_gno'
2955	write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev)
2956	endif
2957	!
2958	! Appeler la convection (au choix)
2959	!
2960	DO k = 1, klev
2961	DO i = 1, klon
2962	conv_q(i,k) = d_q_dyn(i,k) &
2963	+ d_q_vdf(i,k)/dtime
2964	conv_t(i,k) = d_t_dyn(i,k) &
2965	+ d_t_vdf(i,k)/dtime
2966	ENDDO
2967	ENDDO
2968	IF (check) THEN
2969	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
2970	WRITE(lunout,*) "avantcon=", za
2971	ENDIF
2972	zx_ajustq = .FALSE.
2973	IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
2974	IF (zx_ajustq) THEN
2975	DO i = 1, klon
2976	z_avant(i) = 0.0
2977	ENDDO
2978	DO k = 1, klev
2979	DO i = 1, klon
2980	z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k)) &
2981	*(paprs(i,k)-paprs(i,k+1))/RG
2982	ENDDO
2983	ENDDO
2984	ENDIF
2985
2986	! Calcule de vitesse verticale a partir de flux de masse verticale
2987	DO k = 1, klev
2988	DO i = 1, klon
2989	omega(i,k) = RG*flxmass_w(i,k) / cell_area(i)
2990	END DO
2991	END DO
2992	if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ', &
2993	omega(igout, :)
2994
2995	IF (iflag_con.EQ.1) THEN
2996	abort_message ='reactiver le call conlmd dans physiq.F'
2997	CALL abort_physic (modname,abort_message,1)
2998	! CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
2999	! . d_t_con, d_q_con,
3000	! . rain_con, snow_con, ibas_con, itop_con)
3001	ELSE IF (iflag_con.EQ.2) THEN
3002	#ifdef ISO
3003	CALL abort_gcm('physiq 2770','isos pas prevus ici',1)
3004	#endif
3005	CALL conflx(dtime, paprs, pplay, t_seri, q_seri, &
3006	conv_t, conv_q, -evap, omega, &
3007	d_t_con, d_q_con, rain_con, snow_con, &
3008	pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
3009	kcbot, kctop, kdtop, pmflxr, pmflxs)
3010	d_u_con = 0.
3011	d_v_con = 0.
3012
3013
3014	WHERE (rain_con < 0.) rain_con = 0.
3015	WHERE (snow_con < 0.) snow_con = 0.
3016	DO i = 1, klon
3017	ibas_con(i) = klev+1 - kcbot(i)
3018	itop_con(i) = klev+1 - kctop(i)
3019	ENDDO
3020	ELSE IF (iflag_con.GE.3) THEN
3021	! nb of tracers for the KE convection:
3022	! MAF la partie traceurs est faite dans phytrac
3023	! on met ntra=1 pour limiter les appels mais on peut
3024	! supprimer les calculs / ftra.
3025
3026	#ifdef ISOVERIF
3027	do k = 1, klev
3028	do i = 1, klon
3029	call iso_verif_positif(q_seri(i,k),'physic 2929')
3030	enddo
3031	enddo
3032	#endif
3033	#ifdef ISO
3034	#ifdef ISOVERIF
3035	write(,) 'physiq 2877'
3036	call iso_verif_noNaN_vect2D( &
3037	& wake_deltaxt, &
3038	& 'physiq 2704c, wake_deltaxt',ntraciso,klon,klev)
3039	do k = 1, klev
3040	do i = 1, klon
3041	do ixt=1,ntraciso
3042	call iso_verif_noNaN(xt_seri(ixt,i,k),'physiq 2757')
3043	enddo ! do ixt=1,ntraciso
3044	enddo !do i = 1, klon
3045	enddo !do k = 1, klev
3046	#endif
3047	#ifdef ISOVERIF
3048	if (iso_eau.gt.0) then
3049	call iso_verif_egalite_vect2D( &
3050	& xt_seri,q_seri, &
3051	& 'physiq 2704a, avant calcul undi',ntraciso,klon,klev)
3052	call iso_verif_egalite_vect2D( &
3053	& wake_deltaxt,wake_deltaq, &
3054	& 'physiq 2704b, wake_deltaq',ntraciso,klon,klev)
3055	endif
3056	if (iso_HDO.gt.0) then
3057	call iso_verif_aberrant_enc_vect2D( &
3058	& xt_seri,q_seri, &
3059	& 'physiq 2709, avant calcul undi',ntraciso,klon,klev)
3060	! call iso_verif_aberrant_vect2D_ns(
3061	! : wake_deltaxt,wake_deltaq,
3062	! : 'physiq 2709b, wake_deltaq',ntraciso,klon,klev)
3063	endif
3064	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3065	do k = 1, klev
3066	do i = 1, klon
3067	if (q_seri(i,k).gt.ridicule) then
3068	if (iso_verif_o18_aberrant_nostop( &
3069	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
3070	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
3071	& 'physiq 2947, avant calcul undi').eq.1) then
3072	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
3073	stop
3074	endif ! if (iso_verif_o18_aberrant_nostop
3075	endif !if (q_seri(i,k).gt.errmax) then
3076	enddo !do i = 1, klon
3077	enddo !do k = 1, klev
3078	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3079	#endif
3080	#endif
3081
3082	ntra = 1
3083
3084	!=======================================================================
3085	!ajout pour la parametrisation des poches froides: calcul de
3086	!t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri
3087	do k=1,klev
3088	do i=1,klon
3089	if (iflag_wake>=1) then
3090	t_wake(i,k) = t_seri(i,k) &
3091	+(1-wake_s(i))*wake_deltat(i,k)
3092	q_wake(i,k) = q_seri(i,k) &
3093	+(1-wake_s(i))*wake_deltaq(i,k)
3094	t_undi(i,k) = t_seri(i,k) &
3095	-wake_s(i)*wake_deltat(i,k)
3096	q_undi(i,k) = q_seri(i,k) &
3097	-wake_s(i)*wake_deltaq(i,k)
3098	#ifdef ISO
3099	do ixt=1,ntraciso
3100	xt_wake(ixt,i,k) = xt_seri(ixt,i,k) &
3101	& +(1-wake_s(i))*wake_deltaxt(ixt,i,k)
3102	xt_undi(ixt,i,k) = xt_seri(ixt,i,k) &
3103	& -wake_s(i)*wake_deltaxt(ixt,i,k)
3104	enddo !do ixt=1,ntraciso
3105	#endif
3106	else
3107	t_wake(i,k) = t_seri(i,k)
3108	q_wake(i,k) = q_seri(i,k)
3109	t_undi(i,k) = t_seri(i,k)
3110	q_undi(i,k) = q_seri(i,k)
3111	#ifdef ISO
3112	do ixt=1,ntraciso
3113	xt_wake(ixt,i,k) =xt_seri(ixt,i,k)
3114	xt_undi(ixt,i,k) =xt_seri(ixt,i,k)
3115	enddo !do ixt=1,ntraciso
3116	#endif
3117	endif
3118	enddo
3119	enddo
3120
3121
3122	#ifdef ISO
3123	#ifdef ISOVERIF
3124	write(,) 'physiq tmp 2952'
3125	if (iso_eau.gt.0) then
3126	call iso_verif_egalite_vect2D( &
3127	& xt_wake,q_wake, &
3128	& 'physiq 2744, calcul wake',ntraciso,klon,klev)
3129	call iso_verif_egalite_vect2D( &
3130	& xt_undi,q_undi, &
3131	& 'physiq 2734, calcul undi',ntraciso,klon,klev)
3132	endif
3133	if (iso_HDO.gt.0) then
3134	call iso_verif_aberrant_vect2D( &
3135	& xt_wake,q_wake, &
3136	& 'physiq 2749, calcul wake',ntraciso,klon,klev)
3137	call iso_verif_aberrant_vect2D( &
3138	& xt_undi,q_undi, &
3139	& 'physiq 2739, calcul undi',ntraciso,klon,klev)
3140	endif
3141	#endif
3142	#endif
3143
3144	#ifdef ISO
3145	if (iflag_wake>=1) then
3146	if (ok_bidouille_wake.eq.1) then
3147	! if (essai_convergence) then
3148	! else !if (essai_convergence) then
3149	! on évite les q_undi négatifs
3150
3151	DO k=1,klev
3152	DO i=1,klon
3153	if (q_undi(i,k).lt.seuil_q_undi) then
3154	wake_deltaq_prec(i,k)=wake_deltaq(i,k)
3155	wake_deltaq(i,k)=(q_seri(i,k)-seuil_q_undi)/wake_s(i)
3156	q_undi(i,k) = q_seri(i,k) &
3157	& -wake_s(i)*wake_deltaq(i,k)
3158	q_wake(i,k) = q_seri(i,k) &
3159	& +(1-wake_s(i))*wake_deltaq(i,k)
3160	do ixt=1,ntraciso
3161	wake_deltaxt(ixt,i,k)=wake_deltaq(i,k) &
3162	& *wake_deltaxt(ixt,i,k)/wake_deltaq_prec(i,k)
3163	xt_wake(ixt,i,k) = xt_seri(ixt,i,k) &
3164	& +(1-wake_s(i))*wake_deltaxt(ixt,i,k)
3165	xt_undi(ixt,i,k) = xt_seri(ixt,i,k) &
3166	& -wake_s(i)*wake_deltaxt(ixt,i,k)
3167	enddo !do ixt=1,ntraciso
3168	#ifdef ISOVERIF
3169	! write(,) 'physiq 348: q_undi<0: i,k=',i,k
3170	! write(,) 'wake_deltaq_prec=',wake_deltaq_prec(i,k)
3171	! write(,) 'q_seri=',q_seri(i,k)
3172	! write(,) 'wake_s=',wake_s(i)
3173	do ixt=1,ntraciso
3174	call iso_verif_noNaN(xt_undi(ixt,i,k), &
3175	& 'physiq 288a')
3176	enddo !do ixt=1,ntraciso
3177	#endif
3178	#ifdef ISOVERIF
3179	if (iso_eau.gt.0) then
3180	call iso_verif_egalite(wake_deltaq(i,k), &
3181	& wake_deltaxt(iso_eau,i,k),'physiq 3070')
3182	call iso_verif_egalite(q_undi(i,k), &
3183	& xt_undi(iso_eau,i,k),'physiq 3073')
3184	endif
3185	#endif
3186	endif !if (wake_deltaq(i,l).gt.q(i,l)/sigmaw(i)) then
3187	enddo !DO i=1,klon
3188	enddo !DO l=1,klev
3189	endif !if (ok_bidouille_wake.eq.1) then
3190	endif !if (iflag_wake>=1) then
3191	#endif
3192	! endif !if (essai_convergence) then
3193
3194
3195	!
3196	!jyg<
3197	! Perform dry adiabatic adjustment on wake profile
3198	! The corresponding tendencies are added to the convective tendencies
3199	! after the call to the convective scheme.
3200	IF (iflag_wake>=1) then
3201	IF (ok_adjwk) THEN
3202	limbas(:) = 1
3203	CALL ajsec(paprs, pplay, t_wake, q_wake, limbas, &
3204	d_t_adjwk, d_q_adjwk &
3205	#ifdef ISO
3206	& ,xt_wake,d_xt_adjwk &
3207	#endif
3208	& )
3209	ENDIF
3210	!
3211	DO k=1,klev
3212	DO i=1,klon
3213	IF (wake_s(i) .GT. 1.e-3) THEN
3214	t_wake(i,k) = t_wake(i,k) + d_t_adjwk(i,k)
3215	q_wake(i,k) = q_wake(i,k) + d_q_adjwk(i,k)
3216	wake_deltat(i,k) = wake_deltat(i,k) + d_t_adjwk(i,k)
3217	wake_deltaq(i,k) = wake_deltaq(i,k) + d_q_adjwk(i,k)
3218	#ifdef ISO
3219	do ixt=1,ntraciso
3220	xt_wake(ixt,i,k) = xt_wake(ixt,i,k) + d_xt_adjwk(ixt,i,k)
3221	wake_deltaxt(ixt,i,k) = wake_deltaxt(ixt,i,k) + d_xt_adjwk(ixt,i,k)
3222	enddo
3223	#endif
3224	ENDIF
3225	ENDDO
3226	ENDDO
3227	ENDIF ! (iflag_wake>=1)
3228	!>jyg
3229	!
3230	!jyg<
3231	CALL alpale( debut, itap, dtime, paprs, omega, t_seri, &
3232	alp_offset, it_wape_prescr, wape_prescr, fip_prescr, &
3233	ale_bl_prescr, alp_bl_prescr, &
3234	wake_pe, wake_fip, &
3235	Ale_bl, Ale_bl_trig, Alp_bl, &
3236	Ale, Alp , Ale_wake, Alp_wake)
3237	!>jyg
3238	!
3239	! sb, oct02:
3240	! Schema de convection modularise et vectorise:
3241	! (driver commun aux versions 3 et 4)
3242	!
3243	IF (ok_cvl) THEN ! new driver for convectL
3244	!
3245
3246	#ifdef ISO
3247	#ifdef ISOVERIF
3248	write(,) 'physiq tmp 3076'
3249	do k=1,klev
3250	do i=1,klon
3251	! call iso_verif_positif(370.0-t_seri(i,k),
3252	! : 'physiq 2872, avant concvl')
3253	call iso_verif_positif(t_seri(i,k)-100.0, &
3254	& 'physiq 2873, avant concvl')
3255	enddo
3256	enddo
3257	#endif
3258	#ifdef ISOVERIF
3259	!write(,) 'physic 2553: avant appel concvl'
3260	!write(,) 'klon=',klon
3261	do k = 1, klev
3262	do i = 1, klon
3263	do ixt=1,ntraciso
3264	call iso_verif_noNaN(xt_seri(ixt,i,k),'physiq 2925a')
3265	call iso_verif_noNaN(xt_undi(ixt,i,k),'physiq 2925b')
3266	enddo ! do ixt=1,ntraciso
3267	enddo !do i = 1, klon
3268	enddo !do k = 1, klev
3269	#endif
3270	#ifdef ISOVERIF
3271	do k = 1, klev
3272	do i = 1, klon
3273	call iso_verif_positif(q_seri(i,k),'physic 3133a')
3274	call iso_verif_positif(q_undi(i,k),'physic 3133b')
3275	enddo
3276	enddo
3277	if (iso_eau.gt.0) then
3278	do k = 1, klev
3279	do i = 1, klon
3280	call iso_verif_egalite_choix( &
3281	& xt_seri(iso_eau,i,k),q_seri(i,k), &
3282	& 'physic 2559',errmax,errmaxrel)
3283	call iso_verif_egalite_choix( &
3284	& xt_undi(iso_eau,i,k),q_undi(i,k), &
3285	& 'physic 2559b',errmax,errmaxrel)
3286	enddo !do i = 1, klon
3287	enddo !do k = 1, klev
3288	endif !if (iso_eau.gt.0) then
3289	if (iso_HDO.gt.0) then
3290	do k = 1, klev
3291	do i = 1, klon
3292	if (q_seri(i,k).gt.ridicule) then
3293	call iso_verif_aberrant_encadre( &
3294	& xt_seri(iso_hdo,i,k)/q_seri(i,k), &
3295	& 'physic 2657')
3296	endif !if (q_seri(i,k).gt.ridicule) then
3297	enddo !do i = 1, klon
3298	enddo !do k = 1, klev
3299	endif !if (iso_HDO.gt.0) then
3300	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3301	do k = 1, klev
3302	do i = 1, klon
3303	if (q_seri(i,k).gt.ridicule) then
3304	call iso_verif_O18_aberrant( &
3305	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
3306	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
3307	& 'physiq 3285')
3308	endif ! if (q_seri(i,k).gt.ridicule) then
3309	enddo
3310	enddo
3311	endif ! if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3312	if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
3313	do i=1,klon
3314	do k=1,nlev
3315	if ((q_seri(i,k).gt.ridicule).and.(l.lt.nlevmaxO17)) then
3316	call iso_verif_aberrant_o17(xt_seri(iso_o17,i,k) &
3317	& /q_seri(i,k),xt_seri(iso_o18,i,k) &
3318	& /q_seri(i,k),'physiq 2781: avat clmain')
3319	endif !if (q_seri(i,k).gt.ridicule) then
3320	enddo
3321	enddo
3322	endif ! if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
3323	#ifdef ISOTRAC
3324	do i=1,klon
3325	do k=1,nlev
3326	call iso_verif_traceur(xt_seri(1,i,k),'physiq 2975')
3327	if (iso_verif_tracpos_choix_nostop(xt_seri(1,i,k), &
3328	& 'physiq 3060, avantconcvl',1e-5) &
3329	& .eq.1) then
3330	write(,) 'i,k=',i,k
3331	!#ifdef ISOVERIF
3332	stop
3333	!#endif
3334	endif !if (iso_verif_tracpos_choix_nostop(xt_seri(1,i,k),
3335	if (option_tmin.eq.1) then
3336	call iso_verif_trac17_q_deltaD(xt_seri(1,i,k), &
3337	& 'physiq 1456, avant concvl')
3338	endif
3339	! call iso_verif_tracpos_choix(xt_seri(1,i,k),
3340	! : 'physiq 3060, avantconcvl',1e-5)
3341	enddo !do k=1,nlev
3342	enddo !do i=1,klon
3343	#endif
3344	! write(,) 'physiq 2585: appel de concvl'
3345	#endif
3346	!ISOVERIF
3347	if ((bidouille_anti_divergence).and. &
3348	& (iso_eau.gt.0)) then
3349	do k=1,klev
3350	do i=1,klon
3351	xt_seri(iso_eau,i,k)= q_seri(i,k)
3352	xt_undi(iso_eau,i,k)= q_undi(i,k)
3353	enddo !do i=1,klon
3354	enddo !do k=1,klev
3355	endif !if ((bidouille_anti_divergence).and. &
3356	#endif
3357	!ISO
3358	!jyg<
3359	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3360	! Calculate the upmost level of deep convection loops: k_upper_cv
3361	! (near 22 km)
3362	izero = klon/2+1/klon
3363	k_upper_cv = klev
3364	DO k = klev,1,-1
3365	IF (pphi(izero,k) > 22.e4) k_upper_cv = k
3366	ENDDO
3367	IF (prt_level .ge. 5) THEN
3368	Print *, 'upmost level of deep convection loops: k_upper_cv = ', &
3369	k_upper_cv
3370	ENDIF
3371	!
3372	!>jyg
3373	IF (type_trac == 'repr') THEN
3374	nbtr_tmp=ntra
3375	ELSE
3376	nbtr_tmp=nbtr
3377	END IF
3378	!jyg iflag_con est dans clesphys
3379	!c CALL concvl (iflag_con,iflag_clos,
3380	CALL concvl (iflag_clos, &
3381	dtime, paprs, pplay, k_upper_cv, t_undi,q_undi, &
3382	t_wake,q_wake,wake_s, &
3383	u_seri,v_seri,tr_seri,nbtr_tmp, &
3384	ALE,ALP, &
3385	sig1,w01, &
3386	d_t_con,d_q_con,d_u_con,d_v_con,d_tr, &
3387	rain_con, snow_con, ibas_con, itop_con, sigd, &
3388	ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0, &
3389	Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl, &
3390	pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, &
3391	! RomP >>>
3392	!! . pmflxr,pmflxs,da,phi,mp,
3393	!! . ftd,fqd,lalim_conv,wght_th)
3394	pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij, &
3395	ftd,fqd,lalim_conv,wght_th, &
3396	ev, ep,epmlmMm,eplaMm, &
3397	wdtrainA,wdtrainM,wght_cvfd,qtc_cv,sigt_cv, &
3398	tau_cld_cv,coefw_cld_cv,epmax_diag &
3399	#ifdef ISO
3400	& ,xt_undi,xt_wake,d_xt_con,xtrain_con,xtsnow_con,fxtd &
3401	& ,xtVprecip,xtVprecipi &
3402	#ifdef DIAGISO
3403	& , qlp,xtlp,qvp,xtvp,xtev,xtclw & ! juste diagnostique
3404	& , wdtrain,xtwdtrain,tadiab &
3405	& , taux_cond_conv &
3406	& , fq_detrainement,fq_ddft,fq_fluxmasse,fq_evapprecip &
3407	& , fxt_detrainement,fxt_ddft,fxt_fluxmasse &
3408	& , fxt_evapprecip,Mi,Amp_diag,tcond,&
3409	& , f_detrainement,q_detrainement,xt_detrainement &
3410	#endif
3411	#endif
3412	& )
3413	! RomP <<<
3414
3415	#ifdef ISO
3416	#ifdef ISOVERIF
3417	! write(,) 'q_detrainement(1,:)=',q_detrainement(1,:)
3418	call iso_verif_noNaN_vect2D(d_xt_con, &
3419	& 'physiq 3203a apres conv',ntraciso,klon,klev)
3420	call iso_verif_noNaN_vect2D(xt_seri, &
3421	& 'physiq 3203b apres conv',ntraciso,klon,klev)
3422	#endif
3423	#ifdef ISOVERIF
3424	#ifdef ISOTRAC
3425	call iso_verif_trac_masse_vect(d_xt_con,klon,klev, &
3426	& 'physiq 3003 apres tend concvl', &
3427	& errmax,errmaxrel)
3428	call iso_verif_traceur_vect(xt_seri,klon,klev, &
3429	& 'physiq 3005 apres tend concvl')
3430	#endif
3431	#endif
3432	#endif
3433
3434	!IM begin
3435	! print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1),
3436	! .dnwd0(1,1),ftd(1,1),fqd(1,1)
3437	!IM end
3438	!IM cf. FH
3439	clwcon0=qcondc
3440	pmfu(:,:)=upwd(:,:)+dnwd(:,:)
3441
3442	do i = 1, klon
3443	if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1
3444	enddo
3445	!
3446	!jyg<
3447	! Add the tendency due to the dry adjustment of the wake profile
3448	IF (iflag_wake>=1) THEN
3449	DO k=1,klev
3450	DO i=1,klon
3451	ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/dtime
3452	fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/dtime
3453	d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k)
3454	d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k)
3455	#ifdef ISO
3456	do ixt=1,ntraciso
3457	fxtd(ixt,i,k) = fxtd(ixt,i,k) + wake_s(i)*d_xt_adjwk(ixt,i,k)/dtime
3458	d_xt_con(ixt,i,k) = d_xt_con(ixt,i,k) + wake_s(i)*d_xt_adjwk(ixt,i,k)
3459	enddo
3460	#endif
3461	ENDDO
3462	ENDDO
3463	ENDIF
3464	!>jyg
3465	!
3466	ELSE ! ok_cvl
3467
3468	! MAF conema3 ne contient pas les traceurs
3469	#ifdef ISO
3470	CALL abort_gcm('physiq 3198','isos pas prevus ici',1)
3471	#endif
3472	CALL conema3 (dtime, &
3473	paprs,pplay,t_seri,q_seri, &
3474	u_seri,v_seri,tr_seri,ntra, &
3475	sig1,w01, &
3476	d_t_con,d_q_con,d_u_con,d_v_con,d_tr, &
3477	rain_con, snow_con, ibas_con, itop_con, &
3478	upwd,dnwd,dnwd0,bas,top, &
3479	Ma,cape,tvp,rflag, &
3480	pbase &
3481	,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr &
3482	,clwcon0)
3483
3484	ENDIF ! ok_cvl
3485
3486	!
3487	! Correction precip
3488	rain_con = rain_con * cvl_corr
3489	snow_con = snow_con * cvl_corr
3490	#ifdef ISO
3491	xtrain_con = xtrain_con * cvl_corr
3492	xtsnow_con = xtsnow_con * cvl_corr
3493	#endif
3494	!
3495
3496	IF (.NOT. ok_gust) THEN
3497	do i = 1, klon
3498	wd(i)=0.0
3499	enddo
3500	ENDIF
3501
3502	! =================================================================== c
3503	! Calcul des proprietes des nuages convectifs
3504	!
3505
3506	! calcul des proprietes des nuages convectifs
3507	clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
3508	IF (iflag_cld_cv == 0) THEN
3509	call clouds_gno &
3510	(klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
3511	ELSE
3512	call clouds_bigauss &
3513	(klon,klev,q_seri,zqsat,qtc_cv,sigt_cv,ptconv,ratqsc,rnebcon0)
3514	ENDIF
3515
3516
3517	! =================================================================== c
3518
3519	DO i = 1, klon
3520	itop_con(i) = min(max(itop_con(i),1),klev)
3521	ibas_con(i) = min(max(ibas_con(i),1),itop_con(i))
3522	ENDDO
3523
3524	DO i = 1, klon
3525	#ifdef CAMMODIF
3526	! camille: pour éviter pb de dépassement d'indice dans les cas
3527	! où i n'est pas un point convectif et donc ibas_con(i)=0
3528	! c'est un pb indépendant des isotopes
3529	if (ibas_con(i).gt.0) then
3530	#endif
3531	ema_pcb(i) = paprs(i,ibas_con(i))
3532	#ifdef CAMMODIF
3533	else ! if (ibas_con(i).gt.0) then
3534	ema_pcb(i) = 0.0
3535	endif ! if (ibas_con(i).gt.0) then
3536	#endif
3537	ENDDO
3538	DO i = 1, klon
3539	! L'idicage de itop_con peut cacher un pb potentiel
3540	! FH sous la dictee de JYG, CR
3541	ema_pct(i) = paprs(i,itop_con(i)+1)
3542
3543	if (itop_con(i).gt.klev-3) then
3544	if(prt_level >= 9) then
3545	write(lunout,*)'La convection monte trop haut '
3546	write(lunout,*)'itop_con(,',i,',)=',itop_con(i)
3547	endif
3548	endif
3549	ENDDO
3550	ELSE IF (iflag_con.eq.0) THEN
3551	write(lunout,*) 'On n appelle pas la convection'
3552	clwcon0=0.
3553	rnebcon0=0.
3554	d_t_con=0.
3555	d_q_con=0.
3556	d_u_con=0.
3557	d_v_con=0.
3558	rain_con=0.
3559	snow_con=0.
3560	bas=1
3561	top=1
3562	#ifdef ISO
3563	d_xt_con=0.
3564	xtrain_con=0.
3565	xtsnow_con=0.
3566	#endif
3567	ELSE
3568	WRITE(lunout,*) "iflag_con non-prevu", iflag_con
3569	call abort_physic("physiq", "", 1)
3570	ENDIF
3571
3572	! CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
3573	! . d_u_con, d_v_con)
3574
3575	CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, &
3576	'convection',abortphy,flag_inhib_tend &
3577	#ifdef ISO
3578	& ,d_xt_con,dxtl0,dxti0 &
3579	#endif
3580	& )
3581
3582
3583	#ifdef ISO
3584	#ifdef ISOVERIF
3585	if (iso_HDO.gt.0) then
3586	call iso_verif_aberrant_enc_vect2D( &
3587	& xt_seri,q_seri, &
3588	& 'physiq 3588: juste apres add_phys_tend',ntraciso,klon,klev)
3589	endif
3590	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3591	call iso_verif_O18_aberrant_enc_vect2D( &
3592	& xt_seri,q_seri, &
3593	& 'physiq 3588b',ntraciso,klon,klev)
3594	endif
3595	#endif
3596	#endif
3597
3598	!-------------------------------------------------------------------------
3599
3600	if (mydebug) then
3601	call writefield_phy('u_seri',u_seri,nbp_lev)
3602	call writefield_phy('v_seri',v_seri,nbp_lev)
3603	call writefield_phy('t_seri',t_seri,nbp_lev)
3604	call writefield_phy('q_seri',q_seri,nbp_lev)
3605	endif
3606
3607	!IM
3608	IF (ip_ebil_phy.ge.2) THEN
3609	ztit='after convect'
3610	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
3611	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
3612	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
3613	!#ifdef ISO
3614	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
3615	!#endif
3616	& )
3617	call diagphy(cell_area,ztit,ip_ebil_phy &
3618	, zero_v, zero_v, zero_v, zero_v, zero_v &
3619	, zero_v, rain_con, snow_con, ztsol &
3620	, d_h_vcol, d_qt, d_ec &
3621	, fs_bound, fq_bound )
3622	END IF
3623	!
3624	IF (check) THEN
3625	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
3626	WRITE(lunout,*)"aprescon=", za
3627	#ifdef ISO
3628	do ixt=1,ntraciso
3629	DO k = 1, klev
3630	DO i = 1, klon
3631	xt_iso(i,k)=xt_seri(ixt,i,k)
3632	xtl_iso(i,k)=xtl_seri(ixt,i,k)
3633	enddo
3634	enddo
3635	zxta(ixt)= qcheck(klon,klev,paprs,xt_iso,xtl_iso,cell_area)
3636	WRITE(lunout,*)"aprescon: ixt: ",ixt, zxta(ixt)
3637	enddo
3638	#endif
3639	zx_t = 0.0
3640	za = 0.0
3641	DO i = 1, klon
3642	za = za + cell_area(i)/REAL(klon)
3643	zx_t = zx_t + (rain_con(i)+ &
3644	snow_con(i))*cell_area(i)/REAL(klon)
3645	ENDDO
3646	zx_t = zx_t/za*dtime
3647	WRITE(lunout,*)"Precip=", zx_t
3648	ENDIF
3649	IF (zx_ajustq) THEN
3650	DO i = 1, klon
3651	z_apres(i) = 0.0
3652	#ifdef ISO
3653	zxt_apres = 0.0
3654	#endif
3655	ENDDO
3656	DO k = 1, klev
3657	DO i = 1, klon
3658	z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k)) &
3659	*(paprs(i,k)-paprs(i,k+1))/RG
3660	ENDDO
3661	ENDDO
3662	#ifdef ISO
3663	DO k = 1, klev
3664	DO i = 1, klon
3665	do ixt=1,ntraciso
3666	zxt_apres(ixt,i) = zxt_apres(ixt,i) &
3667	& + (xt_seri(ixt,i,k)+xtl_seri(ixt,i,k)) &
3668	& *(paprs(i,k)-paprs(i,k+1))/RG
3669	enddo ! do ixt=1,niso
3670	ENDDO
3671	ENDDO
3672	#endif
3673	DO i = 1, klon
3674	z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime) &
3675	/z_apres(i)
3676	ENDDO
3677	#ifdef ISO
3678	DO i = 1, klon
3679	do ixt=1,ntraciso
3680	zxt_factor(ixt,i) = (zxt_avant(ixt,i)-(xtrain_con(ixt,i) &
3681	& +xtsnow_con(ixt,i))*dtime)/zxt_apres(ixt,i)
3682	enddo ! do ixt=1,niso
3683	ENDDO
3684	#endif
3685	DO k = 1, klev
3686	DO i = 1, klon
3687	IF (z_factor(i).GT.(1.0+1.0E-08) .OR. &
3688	z_factor(i).LT.(1.0-1.0E-08)) THEN
3689	q_seri(i,k) = q_seri(i,k) * z_factor(i)
3690	#ifdef ISO
3691	do ixt=1,ntraciso
3692	xt_seri(ixt,i,k)=xt_seri(ixt,i,k)*zxt_factor(ixt,i)
3693	enddo ! do ixt=1,niso
3694	#endif
3695	ENDIF
3696	ENDDO
3697	ENDDO
3698	ENDIF
3699	zx_ajustq=.FALSE.
3700
3701	#ifdef ISO
3702	#ifdef ISOVERIF
3703	write(,) 'physiq 3425'
3704	if (iso_HDO.gt.0) then
3705	call iso_verif_aberrant_enc_vect2D( &
3706	& xt_seri,q_seri, &
3707	& 'physiq 3691a',ntraciso,klon,klev)
3708	endif
3709	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3710	call iso_verif_O18_aberrant_enc_vect2D( &
3711	& xt_seri,q_seri, &
3712	& 'physiq 3691a',ntraciso,klon,klev)
3713	endif
3714	#ifdef ISOTRAC
3715	call iso_verif_traceur_vect(xt_seri,klon,klev, &
3716	& 'physiq 3386 avant wakes')
3717	#endif
3718	#endif
3719	#endif
3720
3721	!
3722	!==========================================================================
3723	!RR:Evolution de la poche froide: on ne fait pas de separation wake/env
3724	!pour la couche limite diffuse pour l instant
3725	!
3726	!
3727	! nrlmd le 22/03/2011---Si on met les poches hors des thermiques
3728	! il faut rajouter cette tendance calcul\'ee hors des poches
3729	! froides
3730	!
3731	if (iflag_wake>=1) then
3732	DO k=1,klev
3733	DO i=1,klon
3734	dt_dwn(i,k) = ftd(i,k)
3735	dq_dwn(i,k) = fqd(i,k)
3736	M_dwn(i,k) = dnwd0(i,k)
3737	M_up(i,k) = upwd(i,k)
3738	dt_a(i,k) = d_t_con(i,k)/dtime - ftd(i,k)
3739	dq_a(i,k) = d_q_con(i,k)/dtime - fqd(i,k)
3740	#ifdef ISO
3741	do ixt=1,ntraciso
3742	dxt_dwn(ixt,i,k) = fxtd(ixt,i,k)
3743	wdxt_PBL(ixt,i,k) = 0.
3744	dxt_a(ixt,i,k) = d_xt_con(ixt,i,k)/dtime - fxtd(ixt,i,k)
3745	udxt_PBL(ixt,i,k) = 0.
3746	enddo !do ixt=1,ntraciso
3747	#endif
3748	ENDDO
3749	ENDDO
3750	!nrlmd+jyg<
3751	DO k=1,klev
3752	DO i=1,klon
3753	wdt_PBL(i,k) = 0.
3754	wdq_PBL(i,k) = 0.
3755	udt_PBL(i,k) = 0.
3756	udq_PBL(i,k) = 0.
3757	#ifdef ISO
3758	do ixt=1,ntraciso
3759	wdxt_PBL(ixt,i,k) = 0.
3760	udxt_PBL(ixt,i,k) = 0.
3761	enddo
3762	#endif
3763	ENDDO
3764	ENDDO
3765	!
3766	IF (mod(iflag_pbl_split,2) .EQ. 1) THEN
3767	DO k=1,klev
3768	DO i=1,klon
3769	wdt_PBL(i,k) = wdt_PBL(i,k) + d_t_vdf_w(i,k)/dtime
3770	wdq_PBL(i,k) = wdq_PBL(i,k) + d_q_vdf_w(i,k)/dtime
3771	udt_PBL(i,k) = udt_PBL(i,k) + d_t_vdf_x(i,k)/dtime
3772	udq_PBL(i,k) = udq_PBL(i,k) + d_q_vdf_x(i,k)/dtime
3773	!! dt_dwn(i,k) = dt_dwn(i,k) + d_t_vdf_w(i,k)/dtime
3774	!! dq_dwn(i,k) = dq_dwn(i,k) + d_q_vdf_w(i,k)/dtime
3775	!! dt_a (i,k) = dt_a(i,k) + d_t_vdf_x(i,k)/dtime
3776	!! dq_a (i,k) = dq_a(i,k) + d_q_vdf_x(i,k)/dtime
3777	#ifdef ISO
3778	do ixt=1,ntraciso
3779	wdxt_PBL(ixt,i,k) = wdxt_PBL(ixt,i,k) + d_xt_vdf_w(ixt,i,k)/dtime
3780	udxt_PBL(ixt,i,k) = udxt_PBL(ixt,i,k) + d_xt_vdf_x(ixt,i,k)/dtime
3781	enddo
3782	#endif
3783	ENDDO
3784	ENDDO
3785	ENDIF
3786	IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
3787	DO k=1,klev
3788	DO i=1,klon
3789	!! dt_dwn(i,k) = dt_dwn(i,k) + 0.
3790	!! dq_dwn(i,k) = dq_dwn(i,k) + 0.
3791	!! dt_a(i,k) = dt_a(i,k) + d_t_ajs(i,k)/dtime
3792	!! dq_a(i,k) = dq_a(i,k) + d_q_ajs(i,k)/dtime
3793	udt_PBL(i,k) = udt_PBL(i,k) + d_t_ajs(i,k)/dtime
3794	udq_PBL(i,k) = udq_PBL(i,k) + d_q_ajs(i,k)/dtime
3795	#ifdef ISO
3796	do ixt=1,ntraciso
3797	udxt_PBL(ixt,i,k) = udxt_PBL(ixt,i,k) + d_xt_ajs(ixt,i,k)/dtime
3798	enddo
3799	#endif
3800
3801	ENDDO
3802	ENDDO
3803	ENDIF
3804	!>nrlmd+jyg
3805
3806	IF (iflag_wake==2) THEN
3807	ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.)
3808	DO k = 1,klev
3809	dt_dwn(:,k)= dt_dwn(:,k)+ &
3810	ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime
3811	dq_dwn(:,k)= dq_dwn(:,k)+ &
3812	ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime
3813	#ifdef ISO
3814	do ixt=1,ntraciso
3815	dxt_dwn(ixt,:,k)= dxt_dwn(ixt,:,k)+ &
3816	& ok_wk_lsp(:)*(d_xt_eva(ixt,:,k)+d_xt_lsc(ixt,:,k)) &
3817	& /dtime
3818	enddo !do ixt=1,ntraciso
3819	#endif
3820
3821	ENDDO
3822	ELSEIF (iflag_wake==3) THEN
3823	ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.)
3824	DO k = 1,klev
3825	DO i=1,klon
3826	IF (rneb(i,k)==0.) THEN
3827	! On ne tient compte des tendances qu'en dehors des
3828	! nuages (c'est-\`a-dire a priri dans une region ou
3829	! l'eau se reevapore).
3830	dt_dwn(i,k)= dt_dwn(i,k)+ &
3831	ok_wk_lsp(i)*d_t_lsc(i,k)/dtime
3832	dq_dwn(i,k)= dq_dwn(i,k)+ &
3833	ok_wk_lsp(i)*d_q_lsc(i,k)/dtime
3834	#ifdef ISO
3835	do ixt=1,ntraciso
3836	dxt_dwn(ixt,:,k)= dxt_dwn(ixt,:,k)+ &
3837	& ok_wk_lsp(:)*d_xt_lsc(ixt,:,k)/dtime
3838	enddo !do ixt=1,ntraciso
3839	#endif
3840	ENDIF
3841	ENDDO
3842	ENDDO
3843	ENDIF
3844
3845	!
3846	!calcul caracteristiques de la poche froide
3847	call calWAKE (paprs,pplay,dtime &
3848	,t_seri,q_seri,omega &
3849	,dt_dwn,dq_dwn,M_dwn,M_up &
3850	,dt_a,dq_a,sigd &
3851	,wdt_PBL,wdq_PBL &
3852	,udt_PBL,udq_PBL &
3853	,wake_deltat,wake_deltaq,wake_dth &
3854	,wake_h,wake_s,wake_dens &
3855	,wake_pe,wake_fip,wake_gfl &
3856	,dt_wake,dq_wake &
3857	,wake_k, t_undi,q_undi &
3858	,wake_omgbdth,wake_dp_omgb &
3859	,wake_dtKE,wake_dqKE &
3860	,wake_dtPBL,wake_dqPBL &
3861	,wake_omg,wake_dp_deltomg &
3862	,wake_spread,wake_Cstar,wake_d_deltat_gw &
3863	,wake_ddeltat,wake_ddeltaq &
3864	#ifdef ISO
3865	& ,xt_seri,dxt_dwn,dxt_a,wdxt_PBL,udxt_PBL &
3866	& ,wake_deltaxt,dxt_wake,xt_undi &
3867	& ,wake_dxtKE,wake_dxtPBL &
3868	#endif
3869	& )
3870	!
3871	!-----------------------------------------------------------------------
3872	! ajout des tendances des poches froides
3873	! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake
3874	! coherent avec les autres d_t_...
3875	d_t_wake(:,:)=dt_wake(:,:)*dtime
3876	d_q_wake(:,:)=dq_wake(:,:)*dtime
3877	#ifdef ISO
3878	d_xt_wake(:,:,:)=dxt_wake(:,:,:)*dtime
3879	#endif
3880	CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake', &
3881	abortphy,flag_inhib_tend &
3882	#ifdef ISO
3883	& ,d_xt_wake,dxtl0,dxti0 &
3884	#endif
3885	& )
3886
3887	#ifdef ISO
3888	#ifdef ISOVERIF
3889	write(,) 'physiq 3504: apres wakes'
3890	if (iso_eau.gt.0) then
3891	call iso_verif_egalite_vect2D( &
3892	& xt_seri,q_seri, &
3893	& 'physiq 3727, apres ajout wakes',ntraciso,klon,klev)
3894	endif
3895	if (iso_HDO.gt.0) then
3896	call iso_verif_aberrant_enc_vect2D( &
3897	& xt_seri,q_seri,'physiq 3540, apres ajout wakes', &
3898	& ntraciso,klon,klev)
3899	endif
3900	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3901	call iso_verif_O18_aberrant_enc_vect2D( &
3902	& xt_seri,q_seri, &
3903	& 'physiq 3540a',ntraciso,klon,klev)
3904	endif
3905	#ifdef ISOTRAC
3906	call iso_verif_traceur_vect(xt_seri,klon,klev, &
3907	& 'physiq 3456 apres calwake')
3908	#endif
3909	#endif
3910	#endif
3911
3912	!------------------------------------------------------------------------
3913
3914	endif ! (iflag_wake>=1)
3915	!
3916	!===================================================================
3917	!JYG
3918	IF (ip_ebil_phy.ge.2) THEN
3919	ztit='after wake'
3920	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
3921	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
3922	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
3923	!#ifdef ISO
3924	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
3925	!#endif
3926	& )
3927	call diagphy(cell_area,ztit,ip_ebil_phy &
3928	, zero_v, zero_v, zero_v, zero_v, zero_v &
3929	, zero_v, zero_v, zero_v, ztsol &
3930	, d_h_vcol, d_qt, d_ec &
3931	, fs_bound, fq_bound )
3932	END IF
3933
3934	! print*,'apres callwake iflag_cld_th=', iflag_cld_th
3935	!
3936	!===================================================================
3937	! Convection seche (thermiques ou ajustement)
3938	!===================================================================
3939	!
3940	call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri &
3941	,seuil_inversion,weak_inversion,dthmin)
3942
3943
3944
3945	d_t_ajsb(:,:)=0.
3946	d_q_ajsb(:,:)=0.
3947	d_t_ajs(:,:)=0.
3948	d_u_ajs(:,:)=0.
3949	d_v_ajs(:,:)=0.
3950	d_q_ajs(:,:)=0.
3951	clwcon0th(:,:)=0.
3952	#ifdef ISO
3953	d_xt_ajs(:,:,:)=0.0
3954	d_xt_ajsb(:,:,:)=0.0
3955	#endif
3956	!
3957	! fm_therm(:,:)=0.
3958	! entr_therm(:,:)=0.
3959	! detr_therm(:,:)=0.
3960	!
3961	IF(prt_level>9)WRITE(lunout,*) &
3962	'AVANT LA CONVECTION SECHE , iflag_thermals=' &
3963	,iflag_thermals,' nsplit_thermals=',nsplit_thermals
3964	if(iflag_thermals<0) then
3965	! Rien
3966	! ====
3967	IF(prt_level>9)WRITE(lunout,*)'pas de convection seche'
3968
3969	#ifdef ISO
3970	#ifdef ISOVERIF
3971	call iso_verif_noNaN_vect2D(xt_seri,'physiq 3971', &
3972	& ntraciso,klon,klev)
3973	#endif
3974	#ifdef ISOVERIF
3975	write(,) 'physiq 3570'
3976	do k=1,klev
3977	do i=1,klon
3978	if (iso_eau.gt.0) then
3979	call iso_verif_egalite_choix(xt_seri(iso_eau,i,k), &
3980	& q_seri(i,k),'physiq 2765',errmax,errmaxrel)
3981	endif !if (iso_eau.gt.0) then
3982	if (iso_HDO.gt.0) then
3983	if (q_seri(i,k).gt.ridicule) then
3984	call iso_verif_aberrant_encadre(xt_seri(iso_HDO,i,k)/ &
3985	& q_seri(i,k),'physiq 2770')
3986	endif !if (abs(d_q_ajs(i,k)).gt.ridicule) then
3987	endif !if (iso_HDO.gt.0) then
3988	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3989	if (q_seri(i,k).gt.ridicule) then
3990	if (iso_verif_o18_aberrant_nostop( &
3991	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
3992	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
3993	& 'physiq 3978, avant calltherm').eq.1) then
3994	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
3995	stop
3996	endif ! if (iso_verif_o18_aberrant_nostop
3997	endif !if (q_seri(i,k).gt.errmax) then
3998	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
3999	if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
4000	if ((q_seri(i,k).gt.ridicule).and.(l.lt.nlevmaxO17)) then
4001	call iso_verif_aberrant_o17(xt_seri(iso_o17,i,k) &
4002	& /q_seri(i,k),xt_seri(iso_o18,i,k) &
4003	& /q_seri(i,k),'physiq 3178: avant clmain')
4004	endif !if (q_seri(i,k).gt.ridicule) then
4005	endif !if (iso_O17.gt.0) then
4006	#ifdef ISOTRAC
4007	call iso_verif_traceur(xt_seri(1,i,k),'physiq 3389')
4008	if (iso_verif_tracpos_choix_nostop(xt_seri(1,i,k), &
4009	& 'physiq 3481, avant ajsec',1e-5) &
4010	& .eq.1) then
4011	write(,) 'i,k=',i,k
4012	#ifdef ISOVERIF
4013	stop
4014	#endif
4015	!#ifdef ISOVERIF
4016	endif !if (iso_verif_tracpos_choix_nostop(xt_seri(1,i,k),
4017	#endif
4018	!#ifdef ISOTRAC
4019	enddo !do i=1,klon
4020	enddo !do k=1,klev
4021	#endif
4022	!#ifdef ISOVERIF
4023	if ((iso_eau.gt.0).and.(bidouille_anti_divergence)) then
4024	do k=1,klev
4025	do i=1,klon
4026	xt_seri(iso_eau,i,k)=q_seri(i,k)
4027	enddo !do i=1,klon
4028	enddo !do k=1,klev
4029	#ifdef ISOTRAC
4030	call iso_verif_traceur_jbid_vect(xt_seri, &
4031	& klon,klev)
4032	#endif
4033	endif !if ((iso_eau.gt.0).and.(bidouille_anti_divergence)) then
4034	#endif
4035	!#ifdef ISO
4036
4037
4038	else
4039
4040	! Thermiques
4041	! ==========
4042	IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals=' &
4043	,iflag_thermals,' nsplit_thermals=',nsplit_thermals
4044
4045
4046	!cc nrlmd le 10/04/2012
4047	DO k=1,klev+1
4048	DO i=1,klon
4049	pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce)
4050	pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter)
4051	pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic)
4052	pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic)
4053	ENDDO
4054	ENDDO
4055	!cc fin nrlmd le 10/04/2012
4056
4057	if (iflag_thermals>=1) then
4058	!jyg<
4059	IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
4060	! Appel des thermiques avec les profils exterieurs aux poches
4061	DO k=1,klev
4062	DO i=1,klon
4063	t_therm(i,k) = t_seri(i,k) - wake_s(i)*wake_deltat(i,k)
4064	q_therm(i,k) = q_seri(i,k) - wake_s(i)*wake_deltaq(i,k)
4065	u_therm(i,k) = u_seri(i,k)
4066	v_therm(i,k) = v_seri(i,k)
4067	#ifdef ISO
4068	do ixt=1,ntraciso
4069	xt_therm(ixt,i,k) = xt_seri(ixt,i,k) - wake_s(i)*wake_deltaxt(ixt,i,k)
4070	enddo !do ixt=1,ntraciso
4071	#endif
4072	ENDDO
4073	ENDDO
4074	ELSE
4075	! Appel des thermiques avec les profils moyens
4076	DO k=1,klev
4077	DO i=1,klon
4078	t_therm(i,k) = t_seri(i,k)
4079	q_therm(i,k) = q_seri(i,k)
4080	u_therm(i,k) = u_seri(i,k)
4081	v_therm(i,k) = v_seri(i,k)
4082	#ifdef ISO
4083	do ixt=1,ntraciso
4084	xt_therm(ixt,i,k) = xt_seri(ixt,i,k)
4085	enddo !do ixt=1,ntraciso
4086	#endif
4087	ENDDO
4088	ENDDO
4089	ENDIF
4090	!>jyg
4091	call calltherm(pdtphys &
4092	,pplay,paprs,pphi,weak_inversion &
4093	! ,u_seri,v_seri,t_seri,q_seri,zqsat,debut & !jyg
4094	,u_therm,v_therm,t_therm,q_therm,zqsat,debut & !jyg
4095	,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs &
4096	,fm_therm,entr_therm,detr_therm &
4097	,zqasc,clwcon0th,lmax_th,ratqscth &
4098	,ratqsdiff,zqsatth &
4099	!on rajoute ale et alp, et les
4100	!caracteristiques de la couche alim
4101	,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca &
4102	,ztv,zpspsk,ztla,zthl &
4103	!cc nrlmd le 10/04/2012
4104	,pbl_tke_input,pctsrf,omega,cell_area &
4105	,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &
4106	,n2,s2,ale_bl_stat &
4107	,therm_tke_max,env_tke_max &
4108	,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &
4109	,alp_bl_conv,alp_bl_stat &
4110	!cc fin nrlmd le 10/04/2012
4111	,zqla,ztva &
4112	#ifdef ISO
4113	& ,xt_seri,d_xt_ajs &
4114	#ifdef DIAGISO
4115	& ,q_the,xt_the &
4116	#endif
4117	#endif
4118	& )
4119
4120	#ifdef ISO
4121	#ifdef ISOVERIF
4122	write(,) 'physiq 3651: apres calltherm'
4123	if (iso_HDO.gt.0) then
4124	call iso_verif_aberrant_enc_vect2D( &
4125	& xt_seri,q_seri, &
4126	& 'physiq 4084, apres calltherm',ntraciso,klon,klev)
4127	endif
4128
4129	#ifdef ISOTRAC
4130	call iso_verif_traceur_vect(xt_seri,klon,klev, &
4131	& 'physiq 3600 apres calltherm')
4132	#endif
4133	#endif
4134	#endif
4135	!
4136	!jyg<
4137	IF (mod(iflag_pbl_split/2,2) .EQ. 1) THEN
4138	! Si les thermiques ne sont presents que hors des
4139	! poches, la tendance moyenne associ\'ee doit etre
4140	! multipliee par la fraction surfacique qu'ils couvrent.
4141	DO k=1,klev
4142	DO i=1,klon
4143	!
4144	wake_deltat(i,k) = wake_deltat(i,k) - d_t_ajs(i,k)
4145	wake_deltaq(i,k) = wake_deltaq(i,k) - d_q_ajs(i,k)
4146	!
4147	!!!t_seri(i,k) = t_therm(i,k) + wake_s(i)*wake_deltat(i,k)
4148	!!!q_seri(i,k) = q_therm(i,k) + wake_s(i)*wake_deltaq(i,k)
4149	!
4150	d_u_ajs(i,k) = d_u_ajs(i,k)*(1.-wake_s(i))
4151	d_v_ajs(i,k) = d_v_ajs(i,k)*(1.-wake_s(i))
4152	d_t_ajs(i,k) = d_t_ajs(i,k)*(1.-wake_s(i))
4153	d_q_ajs(i,k) = d_q_ajs(i,k)*(1.-wake_s(i))
4154	#ifdef ISO
4155	do ixt=1,ntraciso
4156	wake_deltaxt(ixt,i,k) = wake_deltaxt(ixt,i,k) - d_xt_ajs(ixt,i,k)
4157	d_xt_ajs(ixt,i,k) = d_xt_ajs(ixt,i,k)*(1.-wake_s(i))
4158	enddo
4159	#endif
4160	!
4161	ENDDO
4162	ENDDO
4163	!!! ELSE
4164	!!! DO k=1,klev
4165	!!! DO i=1,klon
4166	!!! t_seri(i,k) = t_therm(i,k)
4167	!!! q_seri(i,k) = q_therm(i,k)
4168	!!! ENDDO
4169	!!! ENDDO
4170	ENDIF
4171	!
4172	CALL add_phys_tend(d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs, &
4173	dql0,dqi0,paprs,'thermals', abortphy,flag_inhib_tend &
4174	#ifdef ISO
4175	& ,d_xt_ajs,dxtl0,dxti0 &
4176	#endif
4177	& )
4178	!
4179	!>jyg
4180	!jyg<
4181	!
4182	CALL alpale_th( dtime, lmax_th, t_seri, cell_area, &
4183	cin, s2, n2, &
4184	ale_bl_trig, ale_bl_stat, ale_bl, &
4185	alp_bl, alp_bl_stat, &
4186	proba_notrig, random_notrig)
4187
4188	! ------------------------------------------------------------------
4189	! Transport de la TKE par les panaches thermiques.
4190	! FH : 2010/02/01
4191	! if (iflag_pbl.eq.10) then
4192	! call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,
4193	! s rg,paprs,pbl_tke)
4194	! endif
4195	! -------------------------------------------------------------------
4196
4197	do i=1,klon
4198	! zmax_th(i)=pphi(i,lmax_th(i))/rg
4199	!CR:04/05/12:correction calcul zmax
4200	zmax_th(i)=zmax0(i)
4201	enddo
4202
4203	endif
4204
4205
4206	! Ajustement sec
4207	! ==============
4208
4209	! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement
4210	! a partir du sommet des thermiques.
4211	! Dans le cas contraire, on demarre au niveau 1.
4212
4213	if (iflag_thermals>=13.or.iflag_thermals<=0) then
4214
4215	if(iflag_thermals.eq.0) then
4216	IF(prt_level>9)WRITE(lunout,*)'ajsec'
4217	limbas(:)=1
4218	else
4219	limbas(:)=lmax_th(:)
4220	endif
4221
4222	! Attention : le call ajsec_convV2 n'est maintenu que momentanneement
4223	! pour des test de convergence numerique.
4224	! Le nouveau ajsec est a priori mieux, meme pour le cas
4225	! iflag_thermals = 0 (l'ancienne version peut faire des tendances
4226	! non nulles numeriquement pour des mailles non concernees.
4227
4228	#ifdef ISO
4229	#ifdef ISOVERIF
4230	call iso_verif_noNaN_vect2D(xt_seri,'physiq 4112', &
4231	& ntraciso,klon,klev)
4232	#endif
4233	#ifdef ISOVERIF
4234	write(,) 'physiq 3691b: avant call ajsec'
4235	if (iso_eau.gt.0) then
4236	call iso_verif_egalite_vect2D( &
4237	& xt_seri,q_seri, &
4238	& 'physiq 3727, avant ajsec',ntraciso,klon,klev)
4239	endif
4240	if (iso_HDO.gt.0) then
4241	call iso_verif_aberrant_enc_vect2D( &
4242	& xt_seri,q_seri, &
4243	& 'physiq 3732, avant ajsec',ntraciso,klon,klev)
4244	endif
4245	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
4246	do k = 1, klev
4247	do i = 1, klon
4248	if (q_seri(i,k).gt.ridicule) then
4249	if (iso_verif_o18_aberrant_nostop( &
4250	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
4251	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
4252	& 'physiq 4051, avant ajsec').eq.1) then
4253	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
4254	stop
4255	endif ! if (iso_verif_o18_aberrant_nostop
4256	endif !if (q_seri(i,k).gt.errmax) then
4257	enddo !do i = 1, klon
4258	enddo !do k = 1, klev
4259	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
4260	#ifdef ISOTRAC
4261	call iso_verif_traceur_vect(xt_seri,klon,klev, &
4262	& 'physiq 3600 avant ajsec')
4263	#endif
4264	!#ifdef ISOTRAC
4265	#endif
4266	!#ifdef ISOVERIF
4267	#endif
4268	!#ifdef ISO
4269
4270	if (iflag_thermals==0) then
4271	! Calling adjustment alone (but not the thermal plume model)
4272	CALL ajsec_convV2(paprs, pplay, t_seri,q_seri &
4273	, d_t_ajsb, d_q_ajsb &
4274	#ifdef ISO
4275	& ,xt_seri,d_xt_ajsb &
4276	#endif
4277	& )
4278	else if (iflag_thermals>0) then
4279	! Calling adjustment above the top of thermal plumes
4280	CALL ajsec(paprs, pplay, t_seri,q_seri,limbas &
4281	, d_t_ajsb, d_q_ajsb &
4282	#ifdef ISO
4283	& ,xt_seri,d_xt_ajsb &
4284	#endif
4285	& )
4286	endif
4287
4288	!--------------------------------------------------------------------
4289	! ajout des tendances de l'ajustement sec ou des thermiques
4290	CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs, &
4291	'ajsb',abortphy,flag_inhib_tend &
4292	#ifdef ISO
4293	& ,d_xt_ajsb,dxtl0,dxti0 &
4294	#endif
4295	& )
4296	d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
4297	d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
4298	#ifdef ISO
4299	d_xt_ajs(:,:,:)=d_xt_ajs(:,:,:)+d_xt_ajsb(:,:,:)
4300	#endif
4301
4302	!---------------------------------------------------------------------
4303
4304	endif
4305
4306	endif
4307	!
4308	!===================================================================
4309	!IM
4310	IF (ip_ebil_phy.ge.2) THEN
4311	ztit='after dry_adjust'
4312	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
4313	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
4314	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
4315	!#ifdef ISO
4316	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
4317	!#endif
4318	& )
4319	call diagphy(cell_area,ztit,ip_ebil_phy &
4320	, zero_v, zero_v, zero_v, zero_v, zero_v &
4321	, zero_v, zero_v, zero_v, ztsol &
4322	, d_h_vcol, d_qt, d_ec &
4323	, fs_bound, fq_bound )
4324	END IF
4325
4326
4327	!-------------------------------------------------------------------------
4328	! Computation of ratqs, the width (normalized) of the subrid scale
4329	! water distribution
4330	CALL calcratqs(klon,klev,prt_level,lunout, &
4331	iflag_ratqs,iflag_con,iflag_cld_th,pdtphys, &
4332	ratqsbas,ratqshaut,ratqsp0, ratqsdp, &
4333	tau_ratqs,fact_cldcon, &
4334	ptconv,ptconvth,clwcon0th, rnebcon0th, &
4335	paprs,pplay,q_seri,zqsat,fm_therm, &
4336	ratqs,ratqsc)
4337
4338	#ifdef ISO
4339	! expérience de sensi ciblée à ratqs
4340	if (modif_ratqs.eq.1) then
4341	! x3 seulement dans extratropiques
4342	do k=1,klev
4343	do i=1, klon
4344	if (abs(latitude_deg(i)).gt.30.0) then
4345	ratqs(i,k)=3.0*ratqs(i,k)
4346	endif
4347	enddo
4348	enddo
4349	endif
4350	#endif
4351
4352	!
4353	! Appeler le processus de condensation a grande echelle
4354	! et le processus de precipitation
4355	!-------------------------------------------------------------------------
4356	IF (prt_level .GE.10) THEN
4357	print *,'itap, ->fisrtilp ',itap
4358	ENDIF
4359	!
4360	#ifdef ISO
4361	#ifdef ISOVERIF
4362	write(,) 'physiq 3837: verif avant ilp'
4363	#endif
4364	#ifdef ISOVERIF
4365	if (iso_eau.gt.0) then
4366	call iso_verif_egalite_vect2D( &
4367	& xt_seri,q_seri, &
4368	& 'physiq 3709, avant ilp',ntraciso,klon,klev)
4369	endif
4370	if (iso_HDO.gt.0) then
4371	call iso_verif_aberrant_enc_vect2D( &
4372	& xt_seri,q_seri, &
4373	& 'physiq 3714, avant ilp',ntraciso,klon,klev)
4374	endif
4375	#endif
4376	#ifdef ISOVERIF
4377	do k=1,klev
4378	do i=1,klon
4379	if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
4380	if ((q_seri(i,k).gt.ridicule).and.(l.lt.nlevmaxO17)) then
4381	call iso_verif_aberrant_o17(xt_seri(iso_o17,i,k) &
4382	& /q_seri(i,k),xt_seri(iso_o18,i,k) &
4383	& /q_seri(i,k),'physiq 3389')
4384	endif !if (q_seri(i,k).gt.ridicule) then
4385	endif !if (iso_O17.gt.0) then
4386	if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
4387	if (q_seri(i,k).gt.ridicule) then
4388	if (iso_verif_o18_aberrant_nostop( &
4389	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
4390	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
4391	& 'physiq 4177, avant il pleut').eq.1) then
4392	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
4393	stop
4394	endif ! if (iso_verif_o18_aberrant_nostop
4395	endif !if (q_seri(i,k).gt.errmax) then
4396	endif !if ((iso_HDO.gt.0).and.(iso_O18.gt.0)) then
4397	#ifdef ISOTRAC
4398	call iso_verif_traceur(xt_seri(1,i,k),'physiq 3609')
4399	call iso_verif_traceur_pbidouille(xt_seri(1,i,k), &
4400	& 'physiq 3609')
4401	if (iso_verif_tracpos_choix_nostop(xt_seri(1,i,k), &
4402	& 'physiq 3707, avant fisrtilp',1e-5) &
4403	& .eq.1) then
4404	write(,) 'i,k=',i,k
4405	#ifdef ISOVERIF
4406	stop
4407	#endif
4408	endif
4409	if (option_tmin.eq.1) then
4410	call iso_verif_trac17_q_deltaD(xt_seri(1,i,k), &
4411	& 'physiq 3905, avant ilp')
4412	endif
4413	#endif
4414	!ISOTRAC
4415	enddo !do i=1,klon
4416	enddo !do k=1,klev
4417
4418	! verif température
4419	do k=1,klev
4420	do i=1,klon
4421	call iso_verif_positif(370.0-t_seri(i,k), &
4422	& 'physiq 3535, avant il pleut')
4423	call iso_verif_positif(t_seri(i,k)-100.0, &
4424	& 'physiq 3537, avant il pleut')
4425	enddo
4426	enddo
4427	write(,) 'physiq 3113: appel de fisrtilp'
4428	#endif
4429	!ISOVERIF
4430	if ((bidouille_anti_divergence).and. &
4431	& (iso_eau.gt.0)) then
4432	do k=1,klev
4433	do i=1,klon
4434	xt_seri(iso_eau,i,k)= q_seri(i,k)
4435	enddo !do i=1,klon
4436	enddo !do k=1,klev
4437	endif !if ((bidouille_anti_divergence).and. &
4438	#endif
4439	!ISO
4440
4441	CALL fisrtilp(dtime,paprs,pplay, &
4442	t_seri, q_seri,ptconv,ratqs, &
4443	d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, &
4444	rain_lsc, snow_lsc, &
4445	pfrac_impa, pfrac_nucl, pfrac_1nucl, &
4446	frac_impa, frac_nucl, beta_prec_fisrt, &
4447	prfl, psfl, rhcl, &
4448	zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cld_th, &
4449	iflag_ice_thermo &
4450	#ifdef ISO
4451	& ,xt_seri,xtrain_lsc,xtsnow_lsc &
4452	& ,d_xt_lsc,d_xtl_lsc,d_xti_lsc,pxtrfl,pxtsfl &
4453	#ifdef DIAGISO
4454	& ,fcond_ls,taux_cond_ls,taux_precip_ls & ! juste diagnostique
4455	#endif
4456	#endif
4457	& )
4458
4459	#ifdef ISO
4460	#ifdef ISOVERIF
4461	call iso_verif_noNaN_vect2D(xt_seri,'physiq 4555', &
4462	& ntraciso,klon,klev)
4463	#endif
4464	#ifdef ISOVERIF
4465	! write(,) 'physiq 2593: sortie de il pleut!'
4466	do k=1,klev
4467	do i=1,klon
4468	#ifdef ISOVERIF
4469	call iso_verif_positif(q_seri(i,k),'physiq 2301')
4470	#endif
4471	if (iso_eau.gt.0) then
4472	call iso_verif_egalite_choix( &
4473	& d_xt_lsc(iso_eau,i,k),d_q_lsc(i,k), &
4474	& 'physiq 2601',errmax,errmaxrel)
4475	call iso_verif_egalite_choix( &
4476	& d_xtl_lsc(iso_eau,i,k),d_ql_lsc(i,k), &
4477	& 'physiq 2603',errmax,errmaxrel)
4478	endif !if (iso_eau.gt.0) then
4479	if (iso_HDO.gt.0) then
4480	if (q_seri(i,k).gt.ridicule) then
4481	call iso_verif_aberrant(xt_seri(iso_HDO,i,k) &
4482	& /q_seri(i,k),'physiq 3912')
4483	endif !if (q_seri(i,k).gt.ridicule) then
4484	endif !if (iso_HDO.gt.0) then
4485	if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
4486	if ((q_seri(i,k).gt.ridicule).and.(l.lt.nlevmaxO17)) then
4487	call iso_verif_aberrant_o17(xt_seri(iso_o17,i,k) &
4488	& /q_seri(i,k),xt_seri(iso_o18,i,k) &
4489	& /q_seri(i,k),'physiq 2239: apres ilp')
4490	endif !if (q_seri(i,k).gt.ridicule) then
4491	endif !if (iso_O17.gt.0) then
4492	#ifdef ISOTRAC
4493	call iso_verif_traceur(xt_seri(1,i,k),'physiq 3493')
4494	if (option_tmin.eq.1) then
4495	call iso_verif_trac17_q_deltaD(xt_seri(1,i,k), &
4496	& 'physiq 3988, apres ilp')
4497	endif ! if (option_tmin.eq.1) then
4498	#endif
4499	enddo !do i=1,klon
4500	enddo !do k=1,klev
4501	do i=1,klon
4502	if (iso_HDO.gt.0) then
4503	call iso_verif_aberrant_choix(xtsnow_lsc(iso_hdo,i), &
4504	& snow_lsc(i),ridicule_rain,deltalim_snow, &
4505	& 'il pleut apres 3567')
4506	call iso_verif_aberrant_choix(xtrain_lsc(iso_hdo,i), &
4507	& rain_lsc(i),ridicule_rain,deltalim, &
4508	& 'il pleut 3570')
4509	endif !if (iso_HDO.gt.0) then
4510	#ifdef ISOTRAC
4511	call iso_verif_traceur(xtrain_lsc(1,i),'physiq 3703')
4512	call iso_verif_traceur(xtsnow_lsc(1,i),'physiq 3704')
4513	#endif
4514	enddo !do i=1,klon
4515	! fin cam verif
4516	#endif
4517	if (essai_convergence) then
4518	else !if (essai_convergence) then
4519	do k=1,klev
4520	do i=1,klon
4521	q_seri(i,k)=max(0.0,q_seri(i,k))
4522	do ixt=1,ntraciso
4523	xt_seri(ixt,i,k)=max(0.0,xt_seri(ixt,i,k))
4524	enddo
4525	enddo
4526	enddo
4527	endif !if (essai_convergence) then
4528	#if ISOVERIF
4529	do k=1,klev
4530	do i=1,klon
4531	if (iso_HDO.gt.0) then
4532	call iso_verif_aberrant_choix(xtsnow_lsc(iso_hdo,i), &
4533	& snow_lsc(i),ridicule_rain,deltalim_snow, &
4534	& 'physiq 3568, après il pleut')
4535	endif !if (iso_HDO.gt.0) then
4536	enddo !do i=1,klon
4537	enddo !do k=1,klev
4538	#endif
4539	#endif
4540
4541	!
4542	WHERE (rain_lsc < 0) rain_lsc = 0.
4543	WHERE (snow_lsc < 0) snow_lsc = 0.
4544	#ifdef ISO
4545	WHERE (xtrain_lsc < 0) xtrain_lsc = 0.
4546	WHERE (xtsnow_lsc < 0) xtsnow_lsc = 0.
4547	#endif
4548
4549	#ifdef ISO
4550	#ifdef ISOVERIF
4551	DO k = 1, klev
4552	do i=1,klon
4553	if (iso_O18.gt.0.and.iso_HDO.gt.0) then
4554	if (ql_seri(i,k).gt.ridicule) then
4555	call iso_verif_aberrant( &
4556	& xtl_seri(iso_HDO,i,k)/ql_seri(i,k),'physiq 4330')
4557	if (iso_O18.gt.0) then
4558	call iso_verif_o18_aberrant( &
4559	& xtl_seri(iso_HDO,i,k)/ql_seri(i,k), &
4560	& xtl_seri(iso_O18,i,k)/ql_seri(i,k), &
4561	& 'physiq 4335, avant il pleut')
4562	endif ! if (iso_O18.gt.0) then
4563	endif !if (ql_seri(i,k).gt.errmax) then
4564	endif !if (iso_HDO.gt.0) then
4565	ENDDO ! i=1,klon
4566	ENDDO !DO k = 1, klev
4567	#endif
4568	#endif
4569
4570	CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs, &
4571	'lsc',abortphy,flag_inhib_tend &
4572	#ifdef ISO
4573	& ,d_xt_lsc,d_xtl_lsc,d_xti_lsc &
4574	#endif
4575	& )
4576	rain_num(:)=0.
4577	DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse
4578	DO i = 1, klon
4579	IF (ql_seri(i,k)>oliqmax) THEN
4580	rain_num(i)=rain_num(i)+(ql_seri(i,k)-oliqmax)*zmasse(i,k)/pdtphys
4581	#ifdef ISO
4582	do ixt=1,ntraciso
4583	xtl_seri(ixt,i,k)=xtl_seri(ixt,i,k)/ql_seri(i,k)*oliqmax
4584	enddo
4585	#endif
4586	ql_seri(i,k)=oliqmax
4587	ENDIF
4588	ENDDO
4589	ENDDO
4590
4591	!---------------------------------------------------------------------------
4592	DO k = 1, klev
4593	DO i = 1, klon
4594	cldfra(i,k) = rneb(i,k)
4595	!CR: a quoi ca sert? Faut-il ajouter qs_seri?
4596	IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
4597	ENDDO
4598	ENDDO
4599
4600	#ifdef ISO
4601	!#ifdef ISOVERIF
4602	! write(,) 'physiq 4030: verif apres ajout lsc'
4603	!#endif
4604	#ifdef ISOVERIF
4605	call iso_verif_noNaN_vect2D(xt_seri,'physiq 4565', &
4606	& ntraciso,klon,klev)
4607	#endif
4608	#ifdef ISOVERIF
4609	if (iso_eau.gt.0) then
4610	call iso_verif_egalite_vect2D( &
4611	& xt_seri,q_seri, &
4612	& 'physiq 2599, apres ajout lsc',ntraciso,klon,klev)
4613	endif
4614	if (iso_HDO.gt.0) then
4615	call iso_verif_aberrant_enc_vect2D( &
4616	& xt_seri,q_seri, &
4617	& 'physiq 2866, apres ajout lsc',ntraciso,klon,klev)
4618	endif
4619	#endif
4620	#ifdef ISOVERIF
4621	DO k = 1, klev
4622	DO i = 1, klon
4623	if (iso_eau.gt.0) then
4624	call iso_verif_egalite_choix( &
4625	& xtl_seri(iso_eau,i,k),ql_seri(i,k), &
4626	& 'physiq 2601',errmax,errmaxrel)
4627	endif !if (iso_eau.gt.0) then
4628	if (iso_HDO.gt.0) then
4629	if (q_seri(i,k).gt.ridicule) then
4630	if (iso_O18.gt.0) then
4631	if (iso_verif_o18_aberrant_nostop( &
4632	& xt_seri(iso_HDO,i,k)/q_seri(i,k), &
4633	& xt_seri(iso_O18,i,k)/q_seri(i,k), &
4634	& 'physiq 2863, after il pleut').eq.1) then
4635	write(,) 'i,k,q_seri(i,k)=',i,k,q_seri(i,k)
4636	stop
4637	endif
4638	endif ! if (iso_O18.gt.0) then
4639	endif !if (q_seri(i,k).gt.errmax) then
4640	if (ql_seri(i,k).gt.ridicule) then
4641	call iso_verif_aberrant( &
4642	& xtl_seri(iso_HDO,i,k)/ql_seri(i,k),'physiq 2871')
4643	if (iso_O18.gt.0) then
4644	if (iso_verif_o18_aberrant_nostop( &
4645	& xtl_seri(iso_HDO,i,k)/ql_seri(i,k), &
4646	& xtl_seri(iso_O18,i,k)/ql_seri(i,k), &
4647	& 'physiq 2872, after il pleut').eq.1) then
4648	write(,) 'i,k,ql_seri(i,k)=',i,k,ql_seri(i,k)
4649	write(,) 'd_ql_lsc(i,k)=',d_ql_lsc(i,k)
4650	write(,) 'deltaD(d_ql_lsc(i,k))=',deltaD( &
4651	& d_xtl_lsc(iso_HDO,i,k)/d_ql_lsc(i,k))
4652	write(,) 'deltaO(d_ql_lsc(i,k))=',deltaO( &
4653	& d_xtl_lsc(iso_O18,i,k)/d_ql_lsc(i,k))
4654	stop
4655	endif
4656	endif ! if (iso_O18.gt.0) then
4657	endif !if (ql_seri(i,k).gt.errmax) then
4658	endif !if (iso_HDO.gt.0) then
4659	ENDDO ! i=1,klon
4660	ENDDO !DO k = 1, klev
4661	if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then
4662	do i=1,klon
4663	do k=1,nlev
4664	if ((q_seri(i,k).gt.ridicule).and.(l.lt.nlevmaxO17)) then
4665	call iso_verif_aberrant_o17(xt_seri(iso_o17,i,k) &
4666	& /q_seri(i,k),xt_seri(iso_o18,i,k) &
4667	& /q_seri(i,k),'physiq 3549')
4668	endif !if (q_seri(i,k).gt.ridicule) then
4669	enddo !do k=1,nlev
4670	enddo !do i=1,klon
4671	endif !if (iso_O17.gt.0) then
4672	#endif
4673	!#ifdef ISOVERIF
4674	#ifdef ISOTRAC
4675	#ifdef ISOVERIF
4676	call iso_verif_traceur_vect(xt_seri,klon,klev,'physiq 3794')
4677	if (option_tmin.eq.1) then
4678	if (nzone_temp.ge.5) then
4679	call iso_verif_tag17_q_deltaD_vect(xt_seri,klon,klev, &
4680	& 'physiq 3385: apres ilp')
4681	endif ! if (nzone_temp.ge.5) then
4682	endif !if (option_tmin.eq.1) then
4683	#endif
4684	!#ifdef ISOVERIF
4685	if (bidouille_anti_divergence) then
4686	call iso_verif_traceur_jbid_vect(xt_seri, &
4687	& klon,klev)
4688	endif
4689
4690	! si tag 22, on recolorise les zones très convectives dans les
4691	! tropiques
4692	if (option_traceurs.eq.22) then
4693	call isotrac_recolorise_conv(xt_seri,latitude_deg,presnivs,rain_con)
4694	endif
4695
4696	#endif
4697	!#ifdef ISOTRAC
4698	#endif
4699	!#ifdef ISO
4700
4701	IF (check) THEN
4702	za = qcheck(klon,klev,paprs,q_seri,ql_seri,cell_area)
4703	WRITE(lunout,*)"apresilp=", za
4704	#ifdef ISO
4705	do ixt=1,ntraciso
4706	DO k = 1, klev
4707	DO i = 1, klon
4708	xt_iso(i,k)=xt_seri(ixt,i,k)
4709	xtl_iso(i,k)=xtl_seri(ixt,i,k)
4710	enddo
4711	enddo
4712	zxta(ixt)= qcheck(klon,klev,paprs,xt_iso,xtl_iso,cell_area)
4713	WRITE(lunout,*)"apresilp: ixt: ",ixt, zxta(ixt)
4714	enddo !do ixt=1,ntraciso
4715	#endif
4716	zx_t = 0.0
4717	za = 0.0
4718	DO i = 1, klon
4719	za = za + cell_area(i)/REAL(klon)
4720	zx_t = zx_t + (rain_lsc(i) &
4721	+ snow_lsc(i))*cell_area(i)/REAL(klon)
4722	ENDDO
4723	zx_t = zx_t/za*dtime
4724	WRITE(lunout,*)"Precip=", zx_t
4725	ENDIF
4726	!IM
4727	IF (ip_ebil_phy.ge.2) THEN
4728	ztit='after fisrt'
4729	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
4730	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
4731	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
4732	!#ifdef ISO
4733	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
4734	!#endif
4735	& )
4736	call diagphy(cell_area,ztit,ip_ebil_phy &
4737	, zero_v, zero_v, zero_v, zero_v, zero_v &
4738	, zero_v, rain_lsc, snow_lsc, ztsol &
4739	, d_h_vcol, d_qt, d_ec &
4740	, fs_bound, fq_bound )
4741	END IF
4742
4743	if (mydebug) then
4744	call writefield_phy('u_seri',u_seri,nbp_lev)
4745	call writefield_phy('v_seri',v_seri,nbp_lev)
4746	call writefield_phy('t_seri',t_seri,nbp_lev)
4747	call writefield_phy('q_seri',q_seri,nbp_lev)
4748	endif
4749
4750	!
4751	!-------------------------------------------------------------------
4752	! PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
4753	!-------------------------------------------------------------------
4754
4755	! 1. NUAGES CONVECTIFS
4756	!
4757	!IM cf FH
4758	! IF (iflag_cld_th.eq.-1) THEN ! seulement pour Tiedtke
4759	IF (iflag_cld_th.le.-1) THEN ! seulement pour Tiedtke
4760	snow_tiedtke=0.
4761	! print*,'avant calcul de la pseudo precip '
4762	! print*,'iflag_cld_th',iflag_cld_th
4763	if (iflag_cld_th.eq.-1) then
4764	rain_tiedtke=rain_con
4765	else
4766	! print*,'calcul de la pseudo precip '
4767	rain_tiedtke=0.
4768	! print*,'calcul de la pseudo precip 0'
4769	do k=1,klev
4770	do i=1,klon
4771	if (d_q_con(i,k).lt.0.) then
4772	rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys &
4773	*(paprs(i,k)-paprs(i,k+1))/rg
4774	endif
4775	enddo
4776	enddo
4777	endif
4778	!
4779	! call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
4780	!
4781
4782	! Nuages diagnostiques pour Tiedtke
4783	CALL diagcld1(paprs,pplay, &
4784	!IM cf FH. rain_con,snow_con,ibas_con,itop_con,
4785	rain_tiedtke,snow_tiedtke,ibas_con,itop_con, &
4786	diafra,dialiq)
4787	DO k = 1, klev
4788	DO i = 1, klon
4789	IF (diafra(i,k).GT.cldfra(i,k)) THEN
4790	cldliq(i,k) = dialiq(i,k)
4791	cldfra(i,k) = diafra(i,k)
4792	ENDIF
4793	ENDDO
4794	ENDDO
4795
4796	ELSE IF (iflag_cld_th.ge.3) THEN
4797	! On prend pour les nuages convectifs le max du calcul de la
4798	! convection et du calcul du pas de temps precedent diminue d'un facteur
4799	! facttemps
4800	facteur = pdtphys *facttemps
4801	do k=1,klev
4802	do i=1,klon
4803	rnebcon(i,k)=rnebcon(i,k)*facteur
4804	if (rnebcon0(i,k)clwcon0(i,k).gt.rnebcon(i,k)clwcon(i,k)) &
4805	then
4806	rnebcon(i,k)=rnebcon0(i,k)
4807	clwcon(i,k)=clwcon0(i,k)
4808	endif
4809	enddo
4810	enddo
4811
4812	! On prend la somme des fractions nuageuses et des contenus en eau
4813
4814	if (iflag_cld_th>=5) then
4815
4816	do k=1,klev
4817	ptconvth(:,k)=fm_therm(:,k+1)>0.
4818	enddo
4819
4820	if (iflag_coupl==4) then
4821
4822	! Dans le cas iflag_coupl==4, on prend la somme des convertures
4823	! convectives et lsc dans la partie des thermiques
4824	! Le controle par iflag_coupl est peut etre provisoire.
4825	do k=1,klev
4826	do i=1,klon
4827	if (ptconv(i,k).and.ptconvth(i,k)) then
4828	cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
4829	cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
4830	else if (ptconv(i,k)) then
4831	cldfra(i,k)=rnebcon(i,k)
4832	cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
4833	endif
4834	enddo
4835	enddo
4836
4837	else if (iflag_coupl==5) then
4838	do k=1,klev
4839	do i=1,klon
4840	cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
4841	cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
4842	enddo
4843	enddo
4844
4845	else
4846
4847	! Si on est sur un point touche par la convection
4848	! profonde et pas par les thermiques, on prend la
4849	! couverture nuageuse et l'eau nuageuse de la convection
4850	! profonde.
4851
4852	!IM/FH: 2011/02/23
4853	! definition des points sur lesquels ls thermiques sont actifs
4854
4855	do k=1,klev
4856	do i=1,klon
4857	if (ptconv(i,k).and. .not. ptconvth(i,k)) then
4858	cldfra(i,k)=rnebcon(i,k)
4859	cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
4860	endif
4861	enddo
4862	enddo
4863
4864	endif
4865
4866	else
4867
4868	! Ancienne version
4869	cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
4870	cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
4871	endif
4872
4873	ENDIF
4874
4875	! plulsc(:)=0.
4876	! do k=1,klev,-1
4877	! do i=1,klon
4878	! zzz=prfl(:,k)+psfl(:,k)
4879	! if (.not.ptconvth.zzz.gt.0.)
4880	! enddo prfl, psfl,
4881	! enddo
4882	!
4883	! 2. NUAGES STARTIFORMES
4884	!
4885	IF (ok_stratus) THEN
4886	CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
4887	DO k = 1, klev
4888	DO i = 1, klon
4889	IF (diafra(i,k).GT.cldfra(i,k)) THEN
4890	cldliq(i,k) = dialiq(i,k)
4891	cldfra(i,k) = diafra(i,k)
4892	ENDIF
4893	ENDDO
4894	ENDDO
4895	ENDIF
4896	!
4897	! Precipitation totale
4898	!
4899	DO i = 1, klon
4900	rain_fall(i) = rain_con(i) + rain_lsc(i)
4901	snow_fall(i) = snow_con(i) + snow_lsc(i)
4902	ENDDO
4903
4904
4905	#ifdef ISO
4906	DO i = 1, klon
4907	do ixt=1,ntraciso
4908	xtrain_fall(ixt,i)=xtrain_con(ixt,i) + xtrain_lsc(ixt,i)
4909	xtsnow_fall(ixt,i)=xtsnow_con(ixt,i) + xtsnow_lsc(ixt,i)
4910	enddo
4911	ENDDO !DO i = 1, klon
4912	#ifdef ISOVERIF
4913	if (iso_eau.gt.0) then
4914	DO i = 1, klon
4915	call iso_verif_egalite_choix(xtsnow_fall(iso_eau,i), &
4916	& snow_fall(i),'physiq 3387', &
4917	& errmax,errmaxrel)
4918	if (iso_verif_positif_nostop(xtrain_lsc(iso_eau,i), &
4919	& 'physiq 4298').eq.1) then
4920	if (rain_lsc(i).ge.0.0) then
4921	write(,) 'rain_fall(i)=',rain_lsc(i)
4922	stop
4923	endif !if (rain_con(i).ge.0.0) then
4924	endif !if (iso_verif_positif_nostop
4925	if (iso_verif_positif_nostop(xtrain_fall(iso_eau,i), &
4926	& 'physiq 3405').eq.1) then
4927	if (rain_fall(i).ge.0.0) then
4928	write(,) 'rain_fall(i)=',rain_fall(i)
4929	stop
4930	endif !if (rain_con(i).ge.0.0) then
4931	endif !if (iso_verif_positif_nostop
4932	ENDDO !DO i = 1, klon
4933	endif !if (iso_eau.gt.0) then
4934	if (iso_HDO.gt.0) then
4935	DO i = 1, klon
4936	call iso_verif_aberrant_choix(xtsnow_fall(iso_hdo,i), &
4937	& snow_fall(i),ridicule_snow, &
4938	& deltalim_snow,'physiq 3856')
4939	enddo !DO i = 1, klon
4940	endif
4941	#ifdef ISOTRAC
4942	DO i = 1, klon
4943	call iso_verif_traceur(xtrain_fall(1,i),'physiq 4012')
4944	call iso_verif_traceur(xtsnow_fall(1,i),'physiq 4013')
4945	enddo
4946	#endif
4947	#endif
4948	#ifdef ISOVERIF
4949	do i=1,klon
4950	do ixt=1,ntraciso
4951	call iso_verif_noNaN(xtsnow_con(ixt,i), &
4952	& 'physiq 4942')
4953	call iso_verif_noNaN(xtsnow_lsc(ixt,i), &
4954	& 'physiq 4942')
4955	call iso_verif_noNaN(xtsnow_fall(ixt,i), &
4956	& 'physiq 4942')
4957	enddo !do ixt=1,ntraciso
4958	enddo ! do klon
4959	#endif
4960	#endif
4961	#ifdef ISO
4962	if ((iso_eau.gt.0).and.(bidouille_anti_divergence)) then
4963	do i=1,klon
4964	xtrain_fall(iso_eau,i)=rain_fall(i)
4965	enddo !do i=1,klon
4966	endif
4967	#endif
4968
4969	!IM
4970	IF (ip_ebil_phy.ge.2) THEN
4971	ztit="after diagcld"
4972	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
4973	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
4974	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
4975	!#ifdef ISO
4976	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
4977	!#endif
4978	& )
4979	call diagphy(cell_area,ztit,ip_ebil_phy &
4980	, zero_v, zero_v, zero_v, zero_v, zero_v &
4981	, zero_v, zero_v, zero_v, ztsol &
4982	, d_h_vcol, d_qt, d_ec &
4983	, fs_bound, fq_bound )
4984	END IF
4985	!
4986	! Calculer l'humidite relative pour diagnostique
4987	!
4988	DO k = 1, klev
4989	DO i = 1, klon
4990	zx_t = t_seri(i,k)
4991	IF (thermcep) THEN
4992	!! if (iflag_ice_thermo.eq.0) then !jyg
4993	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
4994	!! else !jyg
4995	!! zdelta = MAX(0.,SIGN(1.,t_glace_min-zx_t)) !jyg
4996	!! endif !jyg
4997	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
4998	zx_qs = MIN(0.5,zx_qs)
4999	zcor = 1./(1.-retv*zx_qs)
5000	zx_qs = zx_qs*zcor
5001	ELSE
5002	!! IF (zx_t.LT.t_coup) THEN !jyg
5003	IF (zx_t.LT.rtt) THEN !jyg
5004	zx_qs = qsats(zx_t)/pplay(i,k)
5005	ELSE
5006	zx_qs = qsatl(zx_t)/pplay(i,k)
5007	ENDIF
5008	ENDIF
5009	zx_rh(i,k) = q_seri(i,k)/zx_qs
5010	zqsat(i,k)=zx_qs
5011	ENDDO
5012	ENDDO
5013
5014	!IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle
5015	! equivalente a 2m (tpote) pour diagnostique
5016	!
5017	DO i = 1, klon
5018	tpot(i)=zt2m(i)(100000./paprs(i,1))*RKAPPA
5019	IF (thermcep) THEN
5020	IF(zt2m(i).LT.RTT) then
5021	Lheat=RLSTT
5022	ELSE
5023	Lheat=RLVTT
5024	ENDIF
5025	ELSE
5026	IF (zt2m(i).LT.RTT) THEN
5027	Lheat=RLSTT
5028	ELSE
5029	Lheat=RLVTT
5030	ENDIF
5031	ENDIF
5032	tpote(i) = tpot(i)* &
5033	EXP((Lheat qsat2m(i))/(RCPDzt2m(i)))
5034	ENDDO
5035
5036	IF (type_trac == 'inca') THEN
5037	#ifdef INCA
5038	CALL VTe(VTphysiq)
5039	CALL VTb(VTinca)
5040	calday = REAL(days_elapsed + 1) + jH_cur
5041
5042	call chemtime(itap+itau_phy-1, date0, dtime, itap)
5043	IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN
5044	CALL AEROSOL_METEO_CALC( &
5045	calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, &
5046	prfl,psfl,pctsrf,cell_area, &
5047	latitude_deg,longitude_deg,u10m,v10m)
5048	END IF
5049
5050	zxsnow_dummy(:) = 0.0
5051
5052	CALL chemhook_begin (calday, &
5053	days_elapsed+1, &
5054	jH_cur, &
5055	pctsrf(1,1), &
5056	latitude_deg, &
5057	longitude_deg, &
5058	cell_area, &
5059	paprs, &
5060	pplay, &
5061	coefh(1:klon,1:klev,is_ave), &
5062	pphi, &
5063	t_seri, &
5064	u, &
5065	v, &
5066	wo(:, :, 1), &
5067	q_seri, &
5068	zxtsol, &
5069	zxsnow_dummy, &
5070	solsw, &
5071	albsol1, &
5072	rain_fall, &
5073	snow_fall, &
5074	itop_con, &
5075	ibas_con, &
5076	cldfra, &
5077	nbp_lon, &
5078	nbp_lat-1, &
5079	tr_seri, &
5080	ftsol, &
5081	paprs, &
5082	cdragh, &
5083	cdragm, &
5084	pctsrf, &
5085	pdtphys, &
5086	itap)
5087
5088	CALL VTe(VTinca)
5089	CALL VTb(VTphysiq)
5090	#endif
5091	END IF !type_trac = inca
5092
5093
5094	!
5095	! Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
5096	!
5097	IF (MOD(itaprad,radpas).EQ.0) THEN
5098
5099	!
5100	!jq - introduce the aerosol direct and first indirect radiative forcings
5101	!jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
5102	IF (flag_aerosol .gt. 0) THEN
5103	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
5104	IF (.NOT. aerosol_couple) THEN
5105	!
5106	CALL readaerosol_optic( &
5107	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5108	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5109	mass_solu_aero, mass_solu_aero_pi, &
5110	tau_aero, piz_aero, cg_aero, &
5111	tausum_aero, tau3d_aero)
5112	ENDIF
5113	ELSE ! RRTM radiation
5114	IF (aerosol_couple .AND. config_inca == 'aero' ) THEN
5115	abort_message='config_inca=aero et rrtm=1 impossible'
5116	call abort_physic(modname,abort_message,1)
5117	ELSE
5118	!
5119	#ifdef CPP_RRTM
5120	IF (NSW.EQ.6) THEN
5121	!--new aerosol properties
5122	!
5123	CALL readaerosol_optic_rrtm( debut, aerosol_couple, &
5124	new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5125	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5126	tr_seri, mass_solu_aero, mass_solu_aero_pi, &
5127	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
5128	tausum_aero, tau3d_aero)
5129
5130	ELSE IF (NSW.EQ.2) THEN
5131	!--for now we use the old aerosol properties
5132	!
5133	CALL readaerosol_optic( &
5134	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5135	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5136	mass_solu_aero, mass_solu_aero_pi, &
5137	tau_aero, piz_aero, cg_aero, &
5138	tausum_aero, tau3d_aero)
5139	!
5140	!--natural aerosols
5141	tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:)
5142	piz_aero_sw_rrtm(:,:,1,:)=piz_aero(:,:,3,:)
5143	cg_aero_sw_rrtm (:,:,1,:)=cg_aero (:,:,3,:)
5144	!--all aerosols
5145	tau_aero_sw_rrtm(:,:,2,:)=tau_aero(:,:,2,:)
5146	piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:)
5147	cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:)
5148	ELSE
5149	abort_message='Only NSW=2 or 6 are possible with ' &
5150	// 'aerosols and iflag_rrtm=1'
5151	call abort_physic(modname,abort_message,1)
5152	ENDIF
5153
5154	!--call LW optical properties for tropospheric aerosols
5155	!--only works for INCA aerosol (aerosol_couple = TRUE)
5156	CALL aeropt_lw_rrtm(aerosol_couple,paprs,tr_seri)
5157	!
5158	#else
5159	abort_message='You should compile with -rrtm if running ' &
5160	// 'with iflag_rrtm=1'
5161	call abort_physic(modname,abort_message,1)
5162	#endif
5163	!
5164	ENDIF
5165	ENDIF
5166	ELSE
5167	tausum_aero(:,:,:) = 0.
5168	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
5169	tau_aero(:,:,:,:) = 1.e-15
5170	piz_aero(:,:,:,:) = 1.
5171	cg_aero(:,:,:,:) = 0.
5172	ELSE
5173	tau_aero_sw_rrtm(:,:,:,:) = 1.e-15
5174	tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
5175	piz_aero_sw_rrtm(:,:,:,:) = 1.0
5176	cg_aero_sw_rrtm(:,:,:,:) = 0.0
5177	ENDIF
5178	ENDIF
5179	!
5180	!--STRAT AEROSOL
5181	!--updates tausum_aero,tau_aero,piz_aero,cg_aero
5182	IF (flag_aerosol_strat.GT.0) THEN
5183	IF (prt_level .GE.10) THEN
5184	PRINT *,'appel a readaerosolstrat', mth_cur
5185	ENDIF
5186	IF (iflag_rrtm.EQ.0) THEN
5187	IF (flag_aerosol_strat.EQ.1) THEN
5188	CALL readaerosolstrato(debut)
5189	ELSE
5190	abort_message='flag_aerosol_strat must equal 1 for rrtm=0'
5191	CALL abort_physic(modname,abort_message,1)
5192	ENDIF
5193	ELSE
5194	#ifdef CPP_RRTM
5195	IF (flag_aerosol_strat.EQ.1) THEN
5196	CALL readaerosolstrato1_rrtm(debut)
5197	ELSEIF (flag_aerosol_strat.EQ.2) THEN
5198	CALL stratosphere_mask(t_seri, pplay, latitude_deg)
5199	CALL readaerosolstrato2_rrtm(debut)
5200	ELSE
5201	abort_message='flag_aerosol_strat must equal 1 or 2 for rrtm=1'
5202	CALL abort_physic(modname,abort_message,1)
5203	ENDIF
5204	#else
5205	abort_message='You should compile with -rrtm if running ' &
5206	// 'with iflag_rrtm=1'
5207	CALL abort_physic(modname,abort_message,1)
5208	#endif
5209	ENDIF
5210	ENDIF
5211	!--fin STRAT AEROSOL
5212	!
5213
5214	! Calculer les parametres optiques des nuages et quelques
5215	! parametres pour diagnostiques:
5216	!
5217	IF (aerosol_couple.AND.config_inca=='aero') THEN
5218	mass_solu_aero(:,:) = ccm(:,:,1)
5219	mass_solu_aero_pi(:,:) = ccm(:,:,2)
5220	END IF
5221
5222	IF (ok_newmicro) then
5223	IF (iflag_rrtm.NE.0) THEN
5224	#ifdef CPP_RRTM
5225	IF (ok_cdnc.AND.NRADLP.NE.3) THEN
5226	abort_message='RRTM choix incoherent NRADLP doit etre egal a 3 ' &
5227	// 'pour ok_cdnc'
5228	CALL abort_physic(modname,abort_message,1)
5229	ENDIF
5230	#else
5231
5232	abort_message='You should compile with -rrtm if running with '//'iflag_rrtm=1'
5233	CALL abort_physic(modname,abort_message,1)
5234	#endif
5235	ENDIF
5236	CALL newmicro (ok_cdnc, bl95_b0, bl95_b1, &
5237	paprs, pplay, t_seri, cldliq, cldfra, &
5238	cldtau, cldemi, cldh, cldl, cldm, cldt, cldq, &
5239	flwp, fiwp, flwc, fiwc, &
5240	mass_solu_aero, mass_solu_aero_pi, &
5241	cldtaupi, re, fl, ref_liq, ref_ice, &
5242	ref_liq_pi, ref_ice_pi)
5243	ELSE
5244	CALL nuage (paprs, pplay, &
5245	t_seri, cldliq, cldfra, cldtau, cldemi, &
5246	cldh, cldl, cldm, cldt, cldq, &
5247	ok_aie, &
5248	mass_solu_aero, mass_solu_aero_pi, &
5249	bl95_b0, bl95_b1, &
5250	cldtaupi, re, fl)
5251	ENDIF
5252	!
5253	!IM betaCRF
5254	!
5255	cldtaurad = cldtau
5256	cldtaupirad = cldtaupi
5257	cldemirad = cldemi
5258	cldfrarad = cldfra
5259
5260	!
5261	IF (lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND. &
5262	lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN
5263	!
5264	! global
5265	!
5266	DO k=1, klev
5267	DO i=1, klon
5268	IF (pplay(i,k).GE.pfree) THEN
5269	beta(i,k) = beta_pbl
5270	ELSE
5271	beta(i,k) = beta_free
5272	ENDIF
5273	IF (mskocean_beta) THEN
5274	beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
5275	ENDIF
5276	cldtaurad(i,k) = cldtau(i,k) * beta(i,k)
5277	cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
5278	cldemirad(i,k) = cldemi(i,k) * beta(i,k)
5279	cldfrarad(i,k) = cldfra(i,k) * beta(i,k)
5280	ENDDO
5281	ENDDO
5282	!
5283	ELSE
5284	!
5285	! regional
5286	!
5287	DO k=1, klev
5288	DO i=1,klon
5289	!
5290	IF (longitude_deg(i).ge.lon1_beta.AND. &
5291	longitude_deg(i).le.lon2_beta.AND. &
5292	latitude_deg(i).le.lat1_beta.AND. &
5293	latitude_deg(i).ge.lat2_beta) THEN
5294	IF (pplay(i,k).GE.pfree) THEN
5295	beta(i,k) = beta_pbl
5296	ELSE
5297	beta(i,k) = beta_free
5298	ENDIF
5299	IF (mskocean_beta) THEN
5300	beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
5301	ENDIF
5302	cldtaurad(i,k) = cldtau(i,k) * beta(i,k)
5303	cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
5304	cldemirad(i,k) = cldemi(i,k) * beta(i,k)
5305	cldfrarad(i,k) = cldfra(i,k) * beta(i,k)
5306	ENDIF
5307	!
5308	ENDDO
5309	ENDDO
5310	!
5311	ENDIF
5312
5313	!lecture de la chlorophylle pour le nouvel albedo de Sunghye Baek
5314	IF (ok_chlorophyll) THEN
5315	print*,"-- reading chlorophyll"
5316	CALL readchlorophyll(debut)
5317	ENDIF
5318
5319	!
5320	!jq - introduce the aerosol direct and first indirect radiative forcings
5321	!jq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
5322	IF (flag_aerosol .gt. 0) THEN
5323	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
5324	IF (.NOT. aerosol_couple) THEN
5325	!
5326	CALL readaerosol_optic( &
5327	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5328	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5329	mass_solu_aero, mass_solu_aero_pi, &
5330	tau_aero, piz_aero, cg_aero, &
5331	tausum_aero, tau3d_aero)
5332	ENDIF
5333	ELSE ! RRTM radiation
5334	IF (aerosol_couple .AND. config_inca == 'aero' ) THEN
5335	abort_message='config_inca=aero et rrtm=1 impossible'
5336	call abort_physic(modname,abort_message,1)
5337	ELSE
5338	!
5339	#ifdef CPP_RRTM
5340	IF (NSW.EQ.6) THEN
5341	!--new aerosol properties
5342	!
5343	CALL readaerosol_optic_rrtm( debut, aerosol_couple, &
5344	new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5345	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5346	tr_seri, mass_solu_aero, mass_solu_aero_pi, &
5347	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
5348	tausum_aero, tau3d_aero)
5349
5350	ELSE IF (NSW.EQ.2) THEN
5351	!--for now we use the old aerosol properties
5352	!
5353	CALL readaerosol_optic( &
5354	debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref, &
5355	pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
5356	mass_solu_aero, mass_solu_aero_pi, &
5357	tau_aero, piz_aero, cg_aero, &
5358	tausum_aero, tau3d_aero)
5359	!
5360	!--natural aerosols
5361	tau_aero_sw_rrtm(:,:,1,:)=tau_aero(:,:,3,:)
5362	piz_aero_sw_rrtm(:,:,1,:)=piz_aero(:,:,3,:)
5363	cg_aero_sw_rrtm (:,:,1,:)=cg_aero (:,:,3,:)
5364	!--all aerosols
5365	tau_aero_sw_rrtm(:,:,2,:)=tau_aero(:,:,2,:)
5366	piz_aero_sw_rrtm(:,:,2,:)=piz_aero(:,:,2,:)
5367	cg_aero_sw_rrtm (:,:,2,:)=cg_aero (:,:,2,:)
5368	ELSE
5369	abort_message='Only NSW=2 or 6 are possible with ' &
5370	// 'aerosols and iflag_rrtm=1'
5371	call abort_physic(modname,abort_message,1)
5372	ENDIF
5373
5374	!--call LW optical properties for tropospheric aerosols
5375	!--only works for INCA aerosol (aerosol_couple = TRUE)
5376	CALL aeropt_lw_rrtm(aerosol_couple,paprs,tr_seri)
5377	!
5378	#else
5379	abort_message='You should compile with -rrtm if running ' &
5380	// 'with iflag_rrtm=1'
5381	call abort_physic(modname,abort_message,1)
5382	#endif
5383	!
5384	ENDIF
5385	ENDIF
5386	ELSE
5387	tausum_aero(:,:,:) = 0.
5388	IF (iflag_rrtm .EQ. 0) THEN !--old radiation
5389	tau_aero(:,:,:,:) = 1.e-15
5390	piz_aero(:,:,:,:) = 1.
5391	cg_aero(:,:,:,:) = 0.
5392	ELSE
5393	tau_aero_sw_rrtm(:,:,:,:) = 1.e-15
5394	tau_aero_lw_rrtm(:,:,:,:) = 1.e-15
5395	piz_aero_sw_rrtm(:,:,:,:) = 1.0
5396	cg_aero_sw_rrtm(:,:,:,:) = 0.0
5397	ENDIF
5398	ENDIF
5399	!
5400	!--STRAT AEROSOL
5401	!--updates tausum_aero,tau_aero,piz_aero,cg_aero
5402	IF (flag_aerosol_strat.GT.0) THEN
5403	IF (prt_level .GE.10) THEN
5404	PRINT *,'appel a readaerosolstrat', mth_cur
5405	ENDIF
5406	IF (iflag_rrtm.EQ.0) THEN
5407	IF (flag_aerosol_strat.EQ.1) THEN
5408	CALL readaerosolstrato(debut)
5409	ELSE
5410	abort_message='flag_aerosol_strat must equal 1 for rrtm=0'
5411	call abort_physic(modname,abort_message,1)
5412	ENDIF
5413	ELSE
5414	#ifdef CPP_RRTM
5415	IF (flag_aerosol_strat.EQ.1) THEN
5416	CALL readaerosolstrato1_rrtm(debut)
5417	ELSEIF (flag_aerosol_strat.EQ.2) THEN
5418	CALL stratosphere_mask(t_seri, pplay, latitude_deg)
5419	CALL readaerosolstrato2_rrtm(debut)
5420	ELSE
5421	abort_message='flag_aerosol_strat must equal 1 or 2 for rrtm=1'
5422	call abort_physic(modname,abort_message,1)
5423	ENDIF
5424	#else
5425	abort_message='You should compile with -rrtm if running ' &
5426	// 'with iflag_rrtm=1'
5427	call abort_physic(modname,abort_message,1)
5428	#endif
5429	ENDIF
5430	ENDIF
5431	!--fin STRAT AEROSOL
5432
5433	!--if ok_suntime_rrtm we use ancillay data for RSUN
5434	!--previous values are therefore overwritten
5435	!--this is needed for CMIP6 runs
5436	!--and only possible for new radiation scheme
5437	IF (iflag_rrtm.EQ.1.AND.ok_suntime_rrtm) THEN
5438	#ifdef CPP_RRTM
5439	CALL read_rsun_rrtm(debut)
5440	#endif
5441	ENDIF
5442
5443	if (mydebug) then
5444	call writefield_phy('u_seri',u_seri,nbp_lev)
5445	call writefield_phy('v_seri',v_seri,nbp_lev)
5446	call writefield_phy('t_seri',t_seri,nbp_lev)
5447	call writefield_phy('q_seri',q_seri,nbp_lev)
5448	endif
5449
5450	!
5451	!sonia : If Iflag_radia >=2, pertubation of some variables
5452	!input to radiation (DICE)
5453	!
5454	IF (iflag_radia .ge. 2) THEN
5455	zsav_tsol (:) = zxtsol(:)
5456	call perturb_radlwsw(zxtsol,iflag_radia)
5457	ENDIF
5458
5459	IF (aerosol_couple.AND.config_inca=='aero') THEN
5460	#ifdef INCA
5461	CALL radlwsw_inca &
5462	(kdlon,kflev,dist, rmu0, fract, solaire, &
5463	paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri, &
5464	wo(:, :, 1), &
5465	cldfrarad, cldemirad, cldtaurad, &
5466	heat,heat0,cool,cool0,albpla, &
5467	topsw,toplw,solsw,sollw, &
5468	sollwdown, &
5469	topsw0,toplw0,solsw0,sollw0, &
5470	lwdn0, lwdn, lwup0, lwup, &
5471	swdn0, swdn, swup0, swup, &
5472	ok_ade, ok_aie, &
5473	tau_aero, piz_aero, cg_aero, &
5474	topswad_aero, solswad_aero, &
5475	topswad0_aero, solswad0_aero, &
5476	topsw_aero, topsw0_aero, &
5477	solsw_aero, solsw0_aero, &
5478	cldtaupirad, &
5479	topswai_aero, solswai_aero)
5480	#endif
5481	ELSE
5482	!
5483	!IM calcul radiatif pour le cas actuel
5484	!
5485	RCO2 = RCO2_act
5486	RCH4 = RCH4_act
5487	RN2O = RN2O_act
5488	RCFC11 = RCFC11_act
5489	RCFC12 = RCFC12_act
5490	!
5491	IF (prt_level .GE.10) THEN
5492	print *,' ->radlwsw, number 1 '
5493	ENDIF
5494	!
5495	CALL radlwsw &
5496	(dist, rmu0, fract, &
5497	!albedo SB >>>
5498	! paprs, pplay,zxtsol,albsol1, albsol2, &
5499	paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
5500	!albedo SB <<<
5501	t_seri,q_seri,wo, &
5502	cldfrarad, cldemirad, cldtaurad, &
5503	ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
5504	flag_aerosol_strat, &
5505	tau_aero, piz_aero, cg_aero, &
5506	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
5507	! Rajoute par OB pour RRTM
5508	tau_aero_lw_rrtm, &
5509	cldtaupirad,new_aod, &
5510	zqsat, flwc, fiwc, &
5511	ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
5512	heat,heat0,cool,cool0,albpla, &
5513	topsw,toplw,solsw,sollw, &
5514	sollwdown, &
5515	topsw0,toplw0,solsw0,sollw0, &
5516	lwdn0, lwdn, lwup0, lwup, &
5517	swdn0, swdn, swup0, swup, &
5518	topswad_aero, solswad_aero, &
5519	topswai_aero, solswai_aero, &
5520	topswad0_aero, solswad0_aero, &
5521	topsw_aero, topsw0_aero, &
5522	solsw_aero, solsw0_aero, &
5523	topswcf_aero, solswcf_aero, &
5524	!-C. Kleinschmitt for LW diagnostics
5525	toplwad_aero, sollwad_aero,&
5526	toplwai_aero, sollwai_aero, &
5527	toplwad0_aero, sollwad0_aero,&
5528	!-end
5529	ZLWFT0_i, ZFLDN0, ZFLUP0, &
5530	ZSWFT0_i, ZFSDN0, ZFSUP0)
5531
5532	!--OB 30/05/2016
5533	!--here we return swaero_diag to FALSE
5534	!--and histdef will switch it back to TRUE if necessary
5535	!--this is necessary to get the right swaero at first step
5536	IF (debut) swaero_diag = .FALSE.
5537	!
5538	!IM 2eme calcul radiatif pour le cas perturbe ou au moins un
5539	!IM des taux doit etre different du taux actuel
5540	!IM Par defaut on a les taux perturbes egaux aux taux actuels
5541	!
5542	if (ok_4xCO2atm) then
5543	if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. &
5544	RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. &
5545	RCFC12_per.NE.RCFC12_act) THEN
5546	!
5547	RCO2 = RCO2_per
5548	RCH4 = RCH4_per
5549	RN2O = RN2O_per
5550	RCFC11 = RCFC11_per
5551	RCFC12 = RCFC12_per
5552	!
5553	IF (prt_level .GE.10) THEN
5554	print *,' ->radlwsw, number 2 '
5555	ENDIF
5556	!
5557	CALL radlwsw &
5558	(dist, rmu0, fract, &
5559	!albedo SB >>>
5560	! paprs, pplay,zxtsol,albsol1, albsol2, &
5561	paprs, pplay,zxtsol,SFRWL,albsol_dir, albsol_dif, &
5562	!albedo SB <<<
5563	t_seri,q_seri,wo, &
5564	cldfra, cldemi, cldtau, &
5565	ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, &
5566	flag_aerosol_strat, &
5567	tau_aero, piz_aero, cg_aero, &
5568	tau_aero_sw_rrtm, piz_aero_sw_rrtm, cg_aero_sw_rrtm, &
5569	! Rajoute par OB pour RRTM
5570	tau_aero_lw_rrtm, &
5571	cldtaupi,new_aod, &
5572	zqsat, flwc, fiwc, &
5573	ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, &
5574	heatp,heat0p,coolp,cool0p,albplap, &
5575	topswp,toplwp,solswp,sollwp, &
5576	sollwdownp, &
5577	topsw0p,toplw0p,solsw0p,sollw0p, &
5578	lwdn0p, lwdnp, lwup0p, lwupp, &
5579	swdn0p, swdnp, swup0p, swupp, &
5580	topswad_aerop, solswad_aerop, &
5581	topswai_aerop, solswai_aerop, &
5582	topswad0_aerop, solswad0_aerop, &
5583	topsw_aerop, topsw0_aerop, &
5584	solsw_aerop, solsw0_aerop, &
5585	topswcf_aerop, solswcf_aerop, &
5586	!-C. Kleinschmitt for LW diagnostics
5587	toplwad_aerop, sollwad_aerop,&
5588	toplwai_aerop, sollwai_aerop, &
5589	toplwad0_aerop, sollwad0_aerop,&
5590	!-end
5591	ZLWFT0_i, ZFLDN0, ZFLUP0, &
5592	ZSWFT0_i, ZFSDN0, ZFSUP0)
5593	endif
5594	endif
5595	!
5596	ENDIF ! aerosol_couple
5597	itaprad = 0
5598	!
5599	! If Iflag_radia >=2, reset pertubed variables
5600	!
5601	IF (iflag_radia .ge. 2) THEN
5602	zxtsol(:) = zsav_tsol (:)
5603	ENDIF
5604	ENDIF ! MOD(itaprad,radpas)
5605	itaprad = itaprad + 1
5606
5607	IF (iflag_radia.eq.0) THEN
5608	IF (prt_level.ge.9) THEN
5609	PRINT *,'--------------------------------------------------'
5610	PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas'
5611	PRINT *,'>>>> heat et cool mis a zero '
5612	PRINT *,'--------------------------------------------------'
5613	END IF
5614	heat=0.
5615	cool=0.
5616	sollw=0. ! MPL 01032011
5617	solsw=0.
5618	radsol=0.
5619	swup=0. ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars
5620	swup0=0.
5621	lwup=0.
5622	lwup0=0.
5623	lwdn=0.
5624	lwdn0=0.
5625	END IF
5626
5627	!
5628	! Calculer radsol a l'exterieur de radlwsw
5629	! pour prendre en compte le cycle diurne
5630	! recode par Olivier Boucher en sept 2015
5631	!
5632	radsol=solsw*swradcorr+sollw
5633
5634	if (ok_4xCO2atm) then
5635	radsolp=solswp*swradcorr+sollwp
5636	endif
5637
5638	!
5639	! Ajouter la tendance des rayonnements (tous les pas)
5640	! avec une correction pour le cycle diurne dans le SW
5641	!
5642
5643	DO k=1, klev
5644	d_t_swr(:,k)=swradcorr(:)heat(:,k)dtime/RDAY
5645	d_t_sw0(:,k)=swradcorr(:)heat0(:,k)dtime/RDAY
5646	d_t_lwr(:,k)=-cool(:,k)*dtime/RDAY
5647	d_t_lw0(:,k)=-cool0(:,k)*dtime/RDAY
5648	ENDDO
5649
5650	CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy,flag_inhib_tend &
5651	#ifdef ISO
5652	& ,dxt0,dxtl0,dxti0 &
5653	#endif
5654	& )
5655	CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy,flag_inhib_tend &
5656	#ifdef ISO
5657	& ,dxt0,dxtl0,dxti0 &
5658	#endif
5659	& )
5660
5661	!
5662	if (mydebug) then
5663	call writefield_phy('u_seri',u_seri,nbp_lev)
5664	call writefield_phy('v_seri',v_seri,nbp_lev)
5665	call writefield_phy('t_seri',t_seri,nbp_lev)
5666	call writefield_phy('q_seri',q_seri,nbp_lev)
5667	endif
5668
5669	!IM
5670	IF (ip_ebil_phy.ge.2) THEN
5671	ztit='after rad'
5672	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
5673	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
5674	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
5675	!#ifdef ISO
5676	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
5677	!#endif
5678	& )
5679	call diagphy(cell_area,ztit,ip_ebil_phy &
5680	, topsw, toplw, solsw, sollw, zero_v &
5681	, zero_v, zero_v, zero_v, ztsol &
5682	, d_h_vcol, d_qt, d_ec &
5683	, fs_bound, fq_bound )
5684	END IF
5685	!
5686	!
5687	! Calculer l'hydrologie de la surface
5688	!
5689	! CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
5690	! . agesno, ftsol,fqsurf,fsnow, ruis)
5691	!
5692
5693	!
5694	! Calculer le bilan du sol et la derive de temperature (couplage)
5695	!
5696	DO i = 1, klon
5697	! bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
5698	! a la demande de JLD
5699	bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
5700	ENDDO
5701	!
5702	!moddeblott(jan95)
5703	! Appeler le programme de parametrisation de l'orographie
5704	! a l'echelle sous-maille:
5705	!
5706	IF (prt_level .GE.10) THEN
5707	print *,' call orography ? ', ok_orodr
5708	ENDIF
5709	!
5710	IF (ok_orodr) THEN
5711	!
5712	! selection des points pour lesquels le shema est actif:
5713	igwd=0
5714	DO i=1,klon
5715	itest(i)=0
5716	! IF ((zstd(i).gt.10.0)) THEN
5717	IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
5718	itest(i)=1
5719	igwd=igwd+1
5720	idx(igwd)=i
5721	ENDIF
5722	ENDDO
5723	! igwdim=MAX(1,igwd)
5724	!
5725	IF (ok_strato) THEN
5726
5727	CALL drag_noro_strato(klon,klev,dtime,paprs,pplay, &
5728	zmea,zstd, zsig, zgam, zthe,zpic,zval, &
5729	igwd,idx,itest, &
5730	t_seri, u_seri, v_seri, &
5731	zulow, zvlow, zustrdr, zvstrdr, &
5732	d_t_oro, d_u_oro, d_v_oro)
5733
5734	ELSE
5735	CALL drag_noro(klon,klev,dtime,paprs,pplay, &
5736	zmea,zstd, zsig, zgam, zthe,zpic,zval, &
5737	igwd,idx,itest, &
5738	t_seri, u_seri, v_seri, &
5739	zulow, zvlow, zustrdr, zvstrdr, &
5740	d_t_oro, d_u_oro, d_v_oro)
5741	ENDIF
5742	!
5743	! ajout des tendances
5744	!-----------------------------------------------------------------------
5745	! ajout des tendances de la trainee de l'orographie
5746	CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro', &
5747	abortphy,flag_inhib_tend &
5748	#ifdef ISO
5749	& ,dxt0,dxtl0,dxti0 &
5750	#endif
5751	& )
5752	!----------------------------------------------------------------------
5753	!
5754	ENDIF ! fin de test sur ok_orodr
5755	!
5756	if (mydebug) then
5757	call writefield_phy('u_seri',u_seri,nbp_lev)
5758	call writefield_phy('v_seri',v_seri,nbp_lev)
5759	call writefield_phy('t_seri',t_seri,nbp_lev)
5760	call writefield_phy('q_seri',q_seri,nbp_lev)
5761	endif
5762
5763	IF (ok_orolf) THEN
5764	!
5765	! selection des points pour lesquels le shema est actif:
5766	igwd=0
5767	DO i=1,klon
5768	itest(i)=0
5769	IF ((zpic(i)-zmea(i)).GT.100.) THEN
5770	itest(i)=1
5771	igwd=igwd+1
5772	idx(igwd)=i
5773	ENDIF
5774	ENDDO
5775	! igwdim=MAX(1,igwd)
5776	!
5777	IF (ok_strato) THEN
5778
5779	CALL lift_noro_strato(klon,klev,dtime,paprs,pplay, &
5780	latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, &
5781	igwd,idx,itest, &
5782	t_seri, u_seri, v_seri, &
5783	zulow, zvlow, zustrli, zvstrli, &
5784	d_t_lif, d_u_lif, d_v_lif )
5785
5786	ELSE
5787	CALL lift_noro(klon,klev,dtime,paprs,pplay, &
5788	latitude_deg,zmea,zstd,zpic, &
5789	itest, &
5790	t_seri, u_seri, v_seri, &
5791	zulow, zvlow, zustrli, zvstrli, &
5792	d_t_lif, d_u_lif, d_v_lif)
5793	ENDIF
5794
5795	! ajout des tendances de la portance de l'orographie
5796	CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, &
5797	'lif', abortphy,flag_inhib_tend &
5798	#ifdef ISO
5799	& ,dxt0,dxtl0,dxti0 &
5800	#endif
5801	& )
5802	ENDIF ! fin de test sur ok_orolf
5803
5804	IF (ok_hines) then
5805	! HINES GWD PARAMETRIZATION
5806	east_gwstress=0.
5807	west_gwstress=0.
5808	du_gwd_hines=0.
5809	dv_gwd_hines=0.
5810	CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, &
5811	u_seri, v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, &
5812	du_gwd_hines, dv_gwd_hines)
5813	zustr_gwd_hines=0.
5814	zvstr_gwd_hines=0.
5815	DO k = 1, klev
5816	zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/dtime &
5817	* (paprs(:, k)-paprs(:, k+1))/rg
5818	zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/dtime &
5819	* (paprs(:, k)-paprs(:, k+1))/rg
5820	ENDDO
5821
5822	d_t_hin(:, :)=0.
5823	CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, &
5824	dqi0, paprs, 'hin', abortphy,flag_inhib_tend &
5825	#ifdef ISO
5826	& ,dxt0,dxtl0,dxti0 &
5827	#endif
5828	& )
5829	ENDIF
5830
5831	IF (.not. ok_hines .and. ok_gwd_rando) then
5832	CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, &
5833	v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, &
5834	dv_gwd_front, east_gwstress, west_gwstress)
5835	zustr_gwd_front=0.
5836	zvstr_gwd_front=0.
5837	DO k = 1, klev
5838	zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/dtime &
5839	* (paprs(:, k)-paprs(:, k+1))/rg
5840	zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/dtime &
5841	* (paprs(:, k)-paprs(:, k+1))/rg
5842	ENDDO
5843
5844	CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, &
5845	paprs, 'front_gwd_rando', abortphy,flag_inhib_tend &
5846	#ifdef ISO
5847	& ,dxt0,dxtl0,dxti0 &
5848	#endif
5849	& )
5850	ENDIF
5851
5852	if (ok_gwd_rando) then
5853	call FLOTT_GWD_rando(DTIME, pplay, t_seri, u_seri, v_seri, &
5854	rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, &
5855	du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress)
5856	CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, &
5857	paprs, 'flott_gwd_rando', abortphy,flag_inhib_tend &
5858	#ifdef ISO
5859	& ,dxt0,dxtl0,dxti0 &
5860	#endif
5861	& )
5862	zustr_gwd_rando=0.
5863	zvstr_gwd_rando=0.
5864	DO k = 1, klev
5865	zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/dtime &
5866	* (paprs(:, k)-paprs(:, k+1))/rg
5867	zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/dtime &
5868	* (paprs(:, k)-paprs(:, k+1))/rg
5869	ENDDO
5870	end if
5871
5872	! STRESS NECESSAIRES: TOUTE LA PHYSIQUE
5873
5874	if (mydebug) then
5875	call writefield_phy('u_seri',u_seri,nbp_lev)
5876	call writefield_phy('v_seri',v_seri,nbp_lev)
5877	call writefield_phy('t_seri',t_seri,nbp_lev)
5878	call writefield_phy('q_seri',q_seri,nbp_lev)
5879	endif
5880
5881	DO i = 1, klon
5882	zustrph(i)=0.
5883	zvstrph(i)=0.
5884	ENDDO
5885	DO k = 1, klev
5886	DO i = 1, klon
5887	zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime* &
5888	(paprs(i,k)-paprs(i,k+1))/rg
5889	zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime* &
5890	(paprs(i,k)-paprs(i,k+1))/rg
5891	ENDDO
5892	ENDDO
5893	!
5894	!IM calcul composantes axiales du moment angulaire et couple des montagnes
5895	!
5896	IF (is_sequential .and. ok_orodr) THEN
5897	CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur, &
5898	ra,rg,romega, &
5899	latitude_deg,longitude_deg,pphis, &
5900	zustrdr,zustrli,zustrph, &
5901	zvstrdr,zvstrli,zvstrph, &
5902	paprs,u,v, &
5903	aam, torsfc)
5904	ENDIF
5905	!IM cf. FLott END
5906	!IM
5907	IF (ip_ebil_phy.ge.2) THEN
5908	ztit='after orography'
5909	CALL diagetpq(cell_area,ztit,ip_ebil_phy,2,2,dtime &
5910	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
5911	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
5912	!#ifdef ISO
5913	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
5914	!#endif
5915	& )
5916	call diagphy(cell_area,ztit,ip_ebil_phy &
5917	, zero_v, zero_v, zero_v, zero_v, zero_v &
5918	, zero_v, zero_v, zero_v, ztsol &
5919	, d_h_vcol, d_qt, d_ec &
5920	, fs_bound, fq_bound )
5921	END IF
5922
5923	#ifdef ISO
5924	#ifdef ISOVERIF
5925	if (iso_HDO.gt.0) then
5926	call iso_verif_aberrant_enc_vect2D( &
5927	& xt_seri,q_seri, &
5928	& 'physiq 5902, juste avant method',ntraciso,klon,klev)
5929	endif
5930	#endif
5931	#endif
5932
5933	!DC Calcul de la tendance due au methane
5934	IF(ok_qch4) THEN
5935	CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay)
5936	! ajout de la tendance d'humidite due au methane
5937	CALL add_phys_tend(du0, dv0, dt0, d_q_ch4*dtime, dql0, dqi0, paprs, &
5938	'q_ch4', abortphy,flag_inhib_tend &
5939	#ifdef ISO
5940	& ,d_xt_ch4*dtime,dxtl0,dxti0 &
5941	#endif
5942	& )
5943	END IF
5944
5945	#ifdef ISO
5946	#ifdef ISOVERIF
5947	if (iso_HDO.gt.0) then
5948	call iso_verif_aberrant_enc_vect2D( &
5949	& xt_seri,q_seri, &
5950	& 'physiq 5924, juste apres method',ntraciso,klon,klev)
5951	endif
5952	#endif
5953	#endif
5954
5955	!
5956	!
5957	!====================================================================
5958	! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..)
5959	!====================================================================
5960	! Abderrahmane 24.08.09
5961
5962	IF (ok_cosp) THEN
5963	! adeclarer
5964	#ifdef CPP_COSP
5965	IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN
5966
5967	IF (prt_level .GE.10) THEN
5968	print*,'freq_cosp',freq_cosp
5969	ENDIF
5970	mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse
5971	! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=',
5972	! s ref_liq,ref_ice
5973	call phys_cosp(itap,dtime,freq_cosp, &
5974	ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, &
5975	ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, &
5976	klon,klev,longitude_deg,latitude_deg,presnivs,overlap, &
5977	JrNt,ref_liq,ref_ice, &
5978	pctsrf(:,is_ter)+pctsrf(:,is_lic), &
5979	zu10m,zv10m,pphis, &
5980	zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, &
5981	qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, &
5982	prfl(:,1:klev),psfl(:,1:klev), &
5983	pmflxr(:,1:klev),pmflxs(:,1:klev), &
5984	mr_ozone,cldtau, cldemi)
5985
5986	! L calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol,
5987	! L cfaddbze,clcalipso2,dbze,cltlidarradar,
5988	! M clMISR,
5989	! R clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp,
5990	! I tauisccp,albisccp,meantbisccp,meantbclrisccp)
5991
5992	ENDIF
5993
5994	#endif
5995	ENDIF !ok_cosp
5996
5997
5998	!c====================================================================
5999	!c Ajout de la production de tritium (naturelle et essais nucléaires)
6000	!c====================================================================
6001	!C
6002	#ifdef ISO
6003	#ifdef ISOVERIF
6004	call iso_verif_noNaN_vect2D(xt_seri, &
6005	& 'physiq 5595: avant appel tritium',ntraciso,klon,klev)
6006	#endif
6007	call iso_tritium(paprs,pplay, &
6008	& zphi,dtime, &
6009	& d_xt_prod_nucl, &
6010	& d_xt_cosmo, &
6011	& d_xt_decroiss, &
6012	& xt_seri)
6013	#ifdef ISOVERIF
6014	call iso_verif_noNaN_vect2D(xt_seri, &
6015	& 'physiq 5607: apres appel tritium',ntraciso,klon,klev)
6016	#endif
6017
6018	#ifdef ISOVERIF
6019	if (iso_HTO.gt.0) then ! Tritium
6020	ixt=iso_HTO
6021	do i=1,klon
6022	do k=1,klev
6023	if (iso_verif_positif_strict_nostop(xt_seri(ixt,i,k), &
6024	& 'physiq 5620 : xt_seri(HTO) nul ou negatif').eq.1) then
6025	write(,) 'ixt,i,klon,k,klev=',ixt,i,klon,k,klev
6026	write(,) 'xt_seri(iso_HTO,i,k)=',xt_seri(ixt,i,k)
6027	stop
6028	endif
6029	enddo
6030	enddo
6031	endif
6032	#endif
6033	! write(,)'itap=',itap
6034	! write(,)'itau_phy=',itau_phy
6035	! write(,)'jD_cur=',jD_cur
6036	#endif
6037	!ifdef ISO
6038
6039	! Marine
6040
6041	IF (ok_airs) then
6042
6043	IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/dtime)).EQ.0) THEN
6044	write(,) 'je vais appeler simu_airs, ok_airs, freq_airs=', &
6045	& ok_airs, freq_airs
6046	call simu_airs(itap,rneb, t_seri, cldemi, fiwc, ref_ice, pphi, pplay, paprs,&
6047	& map_prop_hc,map_prop_hist,&
6048	& map_emis_hc,map_iwp_hc,map_deltaz_hc,map_pcld_hc,map_tcld_hc,&
6049	& map_emis_Cb,map_pcld_Cb,map_tcld_Cb,&
6050	& map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi,&
6051	& map_emis_Anv,map_pcld_Anv,map_tcld_Anv,&
6052	& map_emis_hist,map_iwp_hist,map_deltaz_hist,map_rad_hist,&
6053	& map_ntot,map_hc,map_hist,&
6054	& map_Cb,map_ThCi,map_Anv,&
6055	& alt_tropo )
6056	ENDIF
6057
6058	ENDIF ! ok_airs
6059
6060
6061	! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6062	!AA
6063	!AA Installation de l'interface online-offline pour traceurs
6064	!AA
6065	!====================================================================
6066	! Calcul des tendances traceurs
6067	!====================================================================
6068	!
6069
6070	IF (type_trac=='repr') THEN
6071	sh_in(:,:) = q_seri(:,:)
6072	ELSE
6073	sh_in(:,:) = qx(:,:,ivap)
6074	END IF
6075
6076	call phytrac ( &
6077	itap, days_elapsed+1, jH_cur, debut, &
6078	lafin, dtime, u, v, t, &
6079	paprs, pplay, pmfu, pmfd, &
6080	pen_u, pde_u, pen_d, pde_d, &
6081	cdragh, coefh(1:klon,1:klev,is_ave), fm_therm, entr_therm, &
6082	u1, v1, ftsol, pctsrf, &
6083	zustar, zu10m, zv10m, &
6084	wstar(:,is_ave), ale_bl, ale_wake, &
6085	latitude_deg, longitude_deg, &
6086	frac_impa,frac_nucl, beta_prec_fisrt,beta_prec, &
6087	presnivs, pphis, pphi, albsol1, &
6088	sh_in, rhcl, cldfra, rneb, &
6089	diafra, cldliq, itop_con, ibas_con, &
6090	pmflxr, pmflxs, prfl, psfl, &
6091	da, phi, mp, upwd, &
6092	phi2, d1a, dam, sij, wght_cvfd, & !<<RomP+RL
6093	wdtrainA, wdtrainM, sigd, clw,elij, & !<<RomP
6094	ev, ep, epmlmMm, eplaMm, & !<<RomP
6095	dnwd, aerosol_couple, flxmass_w, &
6096	tau_aero, piz_aero, cg_aero, ccm, &
6097	rfname, &
6098	d_tr_dyn, & !<<RomP
6099	tr_seri)
6100
6101	IF (offline) THEN
6102
6103	IF (prt_level.ge.9) &
6104	print*,'Attention on met a 0 les thermiques pour phystoke'
6105	call phystokenc ( &
6106	nlon,klev,pdtphys,longitude_deg,latitude_deg, &
6107	t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
6108	fm_therm,entr_therm, &
6109	cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, &
6110	frac_impa, frac_nucl, &
6111	pphis,cell_area,dtime,itap, &
6112	qx(:,:,ivap),da,phi,mp,upwd,dnwd)
6113
6114
6115	ENDIF
6116
6117	!
6118	! Calculer le transport de l'eau et de l'energie (diagnostique)
6119	!
6120	CALL transp (paprs,zxtsol, &
6121	t_seri, q_seri, u_seri, v_seri, zphi, &
6122	ve, vq, ue, uq)
6123	!
6124	!IM global posePB BEG
6125	IF(1.EQ.0) THEN
6126	!
6127	CALL transp_lay (paprs,zxtsol, &
6128	t_seri, q_seri, u_seri, v_seri, zphi, &
6129	ve_lay, vq_lay, ue_lay, uq_lay)
6130	!
6131	ENDIF !(1.EQ.0) THEN
6132	!IM global posePB END
6133	! Accumuler les variables a stocker dans les fichiers histoire:
6134	!
6135
6136	!================================================================
6137	! Conversion of kinetic and potential energy into heat, for
6138	! parameterisation of subgrid-scale motions
6139	!================================================================
6140
6141	d_t_ec(:,:)=0.
6142	forall (k=1: nbp_lev) exner(:, k) = (pplay(:, k)/paprs(:,1))**RKAPPA
6143	CALL ener_conserv(klon,klev,pdtphys,u,v,t,qx(:,:,ivap), &
6144	u_seri,v_seri,t_seri,q_seri,pbl_tke(:,:,is_ave)-tke0(:,:), &
6145	zmasse,exner,d_t_ec)
6146	t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:)
6147
6148	!IM
6149	IF (ip_ebil_phy.ge.1) THEN
6150	ztit='after physic'
6151	CALL diagetpq(cell_area,ztit,ip_ebil_phy,1,1,dtime &
6152	, t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay &
6153	, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec &
6154	!#ifdef ISO
6155	! & , xt_seri,xtl_seri,xts_seri,d_xtw, d_xtl, d_xts &
6156	!#endif
6157	& )
6158	! Comme les tendances de la physique sont ajoute dans la dynamique,
6159	! on devrait avoir que la variation d'entalpie par la dynamique
6160	! est egale a la variation de la physique au pas de temps precedent.
6161	! Donc la somme de ces 2 variations devrait etre nulle.
6162
6163	call diagphy(cell_area,ztit,ip_ebil_phy &
6164	, topsw, toplw, solsw, sollw, sens &
6165	, evap, rain_fall, snow_fall, ztsol &
6166	, d_h_vcol, d_qt, d_ec &
6167	, fs_bound, fq_bound )
6168	!
6169	d_h_vcol_phy=d_h_vcol
6170	!
6171	END IF
6172	!
6173	!=======================================================================
6174	! SORTIES
6175	!=======================================================================
6176	!
6177	!IM initialisation + calculs divers diag AMIP2
6178	!
6179	include "calcul_divers.h"
6180	!
6181	!IM Interpolation sur les niveaux de pression du NMC
6182	! -------------------------------------------------
6183	#ifdef CPP_XIOS
6184	!$OMP MASTER
6185	!On recupere la valeur de la missing value donnee dans le xml
6186	CALL xios_get_field_attr("t850",default_value=missing_val_omp)
6187	! PRINT *,"ARNAUD value missing ",missing_val_omp
6188	!$OMP END MASTER
6189	!$OMP BARRIER
6190	missing_val=missing_val_omp
6191	#endif
6192	#ifndef CPP_XIOS
6193	missing_val=missing_val_nf90
6194	#endif
6195	!
6196	include "calcul_STDlev.h"
6197	!
6198	! slp sea level pressure derived from Arpege-IFS : CALL ctstar + CALL pppmer
6199	CALL diag_slp(klon,t_seri,paprs,pplay,pphis,ptstar,pt0,slp)
6200	!
6201	!cc prw = eau precipitable
6202	! prlw = colonne eau liquide
6203	! prlw = colonne eau solide
6204	prw(:) = 0.
6205	prlw(:) = 0.
6206	prsw(:) = 0.
6207	DO k = 1, klev
6208	prw(:) = prw(:) + q_seri(:,k)*zmasse(:,k)
6209	prlw(:) = prlw(:) + ql_seri(:,k)*zmasse(:,k)
6210	prsw(:) = prsw(:) + qs_seri(:,k)*zmasse(:,k)
6211	ENDDO
6212	#ifdef ISO
6213	!#ifdef ISOVERIF
6214	! write(,) 'physiq 4868: calcul prw'
6215	!#endif
6216
6217	DO i = 1, klon
6218	do ixt=1,ntraciso
6219	xtprw(ixt,i) = 0.
6220	DO k = 1, klev
6221	xtprw(ixt,i) = xtprw(ixt,i) + &
6222	& xt_seri(ixt,i,k)*(paprs(i,k)-paprs(i,k+1))/RG
6223	ENDDO !DO k = 1, klev
6224	enddo !do ixt=1,ntraciso
6225	enddo !DO i = 1, klon
6226	#endif
6227	!
6228	IF (type_trac == 'inca') THEN
6229	#ifdef INCA
6230	CALL VTe(VTphysiq)
6231	CALL VTb(VTinca)
6232
6233	CALL chemhook_end ( &
6234	dtime, &
6235	pplay, &
6236	t_seri, &
6237	tr_seri, &
6238	nbtr, &
6239	paprs, &
6240	q_seri, &
6241	cell_area, &
6242	pphi, &
6243	pphis, &
6244	zx_rh)
6245
6246	CALL VTe(VTinca)
6247	CALL VTb(VTphysiq)
6248	#endif
6249	END IF
6250
6251
6252	!
6253	! Convertir les incrementations en tendances
6254	!
6255	IF (prt_level .GE.10) THEN
6256	print *,'Convertir les incrementations en tendances '
6257	ENDIF
6258	!
6259	if (mydebug) then
6260	call writefield_phy('u_seri',u_seri,nbp_lev)
6261	call writefield_phy('v_seri',v_seri,nbp_lev)
6262	call writefield_phy('t_seri',t_seri,nbp_lev)
6263	call writefield_phy('q_seri',q_seri,nbp_lev)
6264	endif
6265
6266	DO k = 1, klev
6267	DO i = 1, klon
6268	d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
6269	d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
6270	d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
6271	d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
6272	d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
6273	!CR: on ajoute le contenu en glace
6274	if (nqo.eq.3) then
6275	d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime
6276	endif
6277	ENDDO
6278	ENDDO
6279
6280	! C Risi: dispatcher les isotopes dans les xt_seri
6281	#ifdef ISO
6282	do ixt=1,ntraciso
6283	DO k = 1, klev
6284	DO i = 1, klon
6285	iq=iqiso(ixt,ivap)
6286	d_qx(i,k,iq) = ( xt_seri(ixt,i,k) - qx(i,k,iq) ) / dtime
6287	iq=iqiso(ixt,iliq)
6288	d_qx(i,k,iq) = ( xtl_seri(ixt,i,k) - qx(i,k,iq) ) / dtime
6289	if (nqo.eq.3) then
6290	iq=iqiso(ixt,isol)
6291	d_qx(i,k,iq) = ( xts_seri(ixt,i,k) - qx(i,k,iq) ) / dtime
6292	endif
6293	enddo !DO i = 1, klon
6294	enddo ! DO k = 1, klev
6295	enddo !do ixt=1,niso
6296	!#ifdef ISOVERIF
6297	! write(,) 'physiq 6120: d_qx(1,1,:)=',d_qx(1,1,:)
6298	! write(,) 'qx(1,1,:)=',qx(1,1,:)
6299	! write(,) 'xt_seri(:,1,1)=',xt_seri(:,1,1)
6300	!#endif
6301	#endif
6302	! #ifdef ISO
6303	!
6304	!CR: nb de traceurs eau: nqo
6305	! IF (nqtot.GE.3) THEN
6306	IF (nqtot.GE.(nqo+1)) THEN
6307	! DO iq = 3, nqtot
6308
6309	! write(,) 'nqtot,nqo=',nqtot,nqo
6310	#ifdef ISO
6311	do itr=1,nqtottr
6312	iq=itr_indice(itr)
6313	DO k = 1, klev
6314	DO i = 1, klon
6315	d_qx(i,k,iq) = ( tr_seri(i,k,itr) - qx(i,k,iq) ) / dtime
6316	ENDDO
6317	ENDDO !DO k = 1, klev
6318	enddo !do itr=1,nqtottr
6319	#else
6320	DO iq = nqo+1, nqtot
6321	itr=iq-nqo
6322	DO k = 1, klev
6323	DO i = 1, klon
6324	! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
6325	! d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime
6326	! modif CRisi
6327	d_qx(i,k,iq) = ( tr_seri(i,k,itr) - qx(i,k,iq) ) / dtime
6328	ENDDO
6329	ENDDO
6330	ENDDO !DO iq = nqo+1, nqtot
6331	#endif
6332	ENDIF
6333
6334	!#ifdef ISOVERIF
6335	! write(,) 'physiq 6155: qx(1,1,:)=',qx(1,1,:)
6336	! write(,) 'physiq 6155b: d_qx(1,1,:)=',d_qx(1,1,:)
6337	!#endif
6338	!
6339	!IM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
6340	!IM global posePB include "write_bilKP_ins.h"
6341	!IM global posePB include "write_bilKP_ave.h"
6342	!
6343	#ifdef ISO
6344	#ifdef ISOVERIF
6345	if (iso_HDO.gt.0) then
6346	call iso_verif_aberrant_enc_vect2D( &
6347	& xt_seri,q_seri, &
6348	& 'physiq 6322, juste avant OB mass fixer',ntraciso,klon,klev)
6349	endif
6350	#endif
6351	#endif
6352
6353	!--OB mass fixer
6354	!--profile is corrected to force mass conservation of water
6355	IF (mass_fixer) THEN
6356	qql2(:)=0.0
6357	DO k = 1, klev
6358	qql2(:)=qql2(:)+(q_seri(:,k)+ql_seri(:,k)+qs_seri(:,k))*zmasse(:,k)
6359	ENDDO
6360	DO i = 1, klon
6361	!--compute ratio of what q+ql should be with conservation to what it is
6362	corrqql=(qql1(i)+(evap(i)-rain_fall(i)-snow_fall(i))*pdtphys)/qql2(i)
6363	DO k = 1, klev
6364	q_seri(i,k) =q_seri(i,k)*corrqql
6365	ql_seri(i,k)=ql_seri(i,k)*corrqql
6366	ENDDO
6367	ENDDO
6368	#ifdef ISO
6369	do ixt=1,ntraciso
6370	xtql2(ixt,:)=0.0
6371	DO k = 1, klev
6372	xtql2(ixt,:)=xtql2(ixt,:)+(xt_seri(ixt,:,k)+xtl_seri(ixt,:,k)+xts_seri(ixt,:,k))*zmasse(:,k)
6373	ENDDO
6374	DO i = 1, klon
6375	!--compute ratio of what q+ql should be with conservation to what it is
6376	corrxtql(ixt)=(xtql1(ixt,i)+(xtevap(ixt,i)-xtrain_fall(ixt,i)-xtsnow_fall(ixt,i))*pdtphys)/xtql2(ixt,i)
6377	DO k = 1, klev
6378	xt_seri(ixt,i,k) =xt_seri(ixt,i,k)*corrxtql(ixt)
6379	xtl_seri(ixt,i,k)=xtl_seri(ixt,i,k)*corrxtql(ixt)
6380	ENDDO
6381	ENDDO
6382	enddo !do ixt=1,ntraciso
6383	#endif
6384	ENDIF
6385
6386	!--fin mass fixer
6387
6388	#ifdef ISO
6389	#ifdef ISOVERIF
6390	if (iso_HDO.gt.0) then
6391	call iso_verif_aberrant_enc_vect2D( &
6392	& xt_seri,q_seri, &
6393	& 'physiq 6367, juste apres OB mass fixer',ntraciso,klon,klev)
6394	endif
6395	#endif
6396	#endif
6397
6398
6399	! Sauvegarder les valeurs de t et q a la fin de la physique:
6400	!
6401	u_ancien(:,:) = u_seri(:,:)
6402	v_ancien(:,:) = v_seri(:,:)
6403	t_ancien(:,:) = t_seri(:,:)
6404	q_ancien(:,:) = q_seri(:,:)
6405	ql_ancien(:,:) = ql_seri(:,:)
6406	qs_ancien(:,:) = qs_seri(:,:)
6407	#ifdef ISO
6408	xt_ancien(:,:,:)=xt_seri(:,:,:)
6409	xtl_ancien(:,:,:)=xtl_seri(:,:,:)
6410	xts_ancien(:,:,:)=xts_seri(:,:,:)
6411	#endif
6412	CALL water_int(klon,klev,q_ancien,zmasse,prw_ancien)
6413	CALL water_int(klon,klev,ql_ancien,zmasse,prlw_ancien)
6414	CALL water_int(klon,klev,qs_ancien,zmasse,prsw_ancien)
6415	! !! RomP >>>
6416	!CR: nb de traceurs eau: nqo
6417	IF (nqtot.GT.nqo) THEN
6418	#ifdef ISO
6419	do itr=1,nqtottr
6420	! iq=itr_indice(itr)
6421	tr_ancien(:,:,itr) = tr_seri(:,:,itr)
6422	enddo !do itr=1,nqtottr
6423	#else
6424	DO iq = nqo+1, nqtot
6425	tr_ancien(:,:,iq-nqo) = tr_seri(:,:,iq-nqo)
6426	ENDDO
6427	#endif
6428	ENDIF
6429	! !! RomP <<<
6430
6431
6432	!==========================================================================
6433	! Sorties des tendances pour un point particulier
6434	! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier
6435	! pour le debug
6436	! La valeur de igout est attribuee plus haut dans le programme
6437	!==========================================================================
6438
6439	if (prt_level.ge.1) then
6440	write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
6441	write(lunout,*) &
6442	'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos'
6443	write(lunout,*) &
6444	nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys, &
6445	pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce), &
6446	pctsrf(igout,is_sic)
6447	write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva'
6448	do k=1,klev
6449	write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k), &
6450	d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k), &
6451	d_t_eva(igout,k)
6452	enddo
6453	write(lunout,*) 'cool,heat'
6454	do k=1,klev
6455	write(lunout,*) cool(igout,k),heat(igout,k)
6456	enddo
6457
6458	!jyg< (En attendant de statuer sur le sort de d_t_oli)
6459	!jyg! write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec'
6460	!jyg! do k=1,klev
6461	!jyg! write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k), &
6462	!jyg! d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
6463	!jyg! enddo
6464	write(lunout,*) 'd_t_vdf,d_t_oro,d_t_lif,d_t_ec'
6465	do k=1,klev
6466	write(lunout,*) d_t_vdf(igout,k), &
6467	d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
6468	enddo
6469	!>jyg
6470
6471	write(lunout,*) 'd_ps ',d_ps(igout)
6472	write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 '
6473	do k=1,klev
6474	write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k), &
6475	d_qx(igout,k,1),d_qx(igout,k,2)
6476	enddo
6477	endif
6478
6479	!==========================================================================
6480
6481	!============================================================
6482	! Calcul de la temperature potentielle
6483	!============================================================
6484	DO k = 1, klev
6485	DO i = 1, klon
6486	!JYG/IM theta en debut du pas de temps
6487	!JYG/IM theta(i,k)=t(i,k)(100000./pplay(i,k))*(RD/RCPD)
6488	!JYG/IM theta en fin de pas de temps de physique
6489	theta(i,k)=t_seri(i,k)(100000./pplay(i,k))*(RD/RCPD)
6490	! thetal: 2 lignes suivantes a decommenter si vous avez les fichiers
6491	! MPL 20130625
6492	! fth_fonctions.F90 et parkind1.F90
6493	! sinon thetal=theta
6494	! thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k),
6495	! : ql_seri(i,k))
6496	thetal(i,k)=theta(i,k)
6497	ENDDO
6498	ENDDO
6499	!
6500
6501	! 22.03.04 BEG
6502	!=============================================================
6503	! Ecriture des sorties
6504	!=============================================================
6505	#ifdef CPP_IOIPSL
6506
6507	! Recupere des varibles calcule dans differents modules
6508	! pour ecriture dans histxxx.nc
6509
6510	! Get some variables from module fonte_neige_mod
6511	CALL fonte_neige_get_vars(pctsrf, &
6512	zxfqcalving, zxfqfonte, zxffonte, zxrunofflic &
6513	#ifdef ISO
6514	& ,zxfxtcalving, zxfxtfonte,zxxtrunofflic &
6515	#endif
6516	& )
6517
6518
6519	!=============================================================
6520	! Separation entre thermiques et non thermiques dans les sorties
6521	! de fisrtilp
6522	!=============================================================
6523
6524	if (iflag_thermals>=1) then
6525	d_t_lscth=0.
6526	d_t_lscst=0.
6527	d_q_lscth=0.
6528	d_q_lscst=0.
6529	do k=1,klev
6530	do i=1,klon
6531	if (ptconvth(i,k)) then
6532	d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
6533	d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
6534	else
6535	d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
6536	d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
6537	endif
6538	enddo
6539	enddo
6540
6541	do i=1,klon
6542	plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1)
6543	plul_th(i)=prfl(i,1)+psfl(i,1)
6544	enddo
6545	endif
6546
6547
6548	!On effectue les sorties:
6549
6550	! write(,) 'physiq tmp 6338'
6551	CALL phys_output_write(itap, pdtphys, paprs, pphis, &
6552	pplay, lmax_th, aerosol_couple, &
6553	ok_ade, ok_aie, ivap, iliq, isol, new_aod, &
6554	ok_sync, ptconv, read_climoz, clevSTD, &
6555	ptconvth, d_t, qx, d_qx, zmasse, &
6556	flag_aerosol, flag_aerosol_strat, ok_cdnc)
6557
6558	include "write_histday_seri.h"
6559
6560	CALL write_paramLMDZ_phy(itap,nid_ctesGCM,ok_sync)
6561
6562	#endif
6563
6564
6565	!====================================================================
6566	! Arret du modele apres hgardfou en cas de detection d'un
6567	! plantage par hgardfou
6568	!====================================================================
6569
6570	IF (abortphy==1) THEN
6571	abort_message ='Plantage hgardfou'
6572	CALL abort_physic (modname,abort_message,1)
6573	ENDIF
6574
6575	! 22.03.04 END
6576	!
6577	!====================================================================
6578	! Si c'est la fin, il faut conserver l'etat de redemarrage
6579	!====================================================================
6580	!
6581	#ifdef ISO
6582	#ifdef ISOVERIF
6583	if (iso_HDO.gt.0) then
6584	call iso_verif_aberrant_enc_vect2D( &
6585	& xt_ancien,q_ancien, &
6586	& 'physiq 6577',ntraciso,klon,klev)
6587	endif
6588	write(,) 'physiq 3731: verif avant phyisoredem'
6589	do k=1,klev
6590	do i=1,klon
6591	if (iso_eau.gt.0) then
6592	call iso_verif_egalite_choix(xt_ancien(iso_eau,i,k), &
6593	& q_ancien(i,k),'physiq 3728: avant phyisoredem', &
6594	& errmax,errmaxrel)
6595	endif ! if (iso_eau.gt.0) then
6596	#ifdef ISOTRAC
6597	if (ok_isotrac) then
6598	call iso_verif_traceur(xt_ancien(1,i,k),'physiq 4802')
6599	endif !if (ok_isotrac) then
6600	#endif
6601	enddo
6602	enddo !do k=1,klev
6603	#endif
6604	#endif
6605	! ISO
6606
6607	IF (lafin) THEN
6608	itau_phy = itau_phy + itap
6609	CALL phyredem ("restartphy.nc")
6610	! open(97,form="unformatted",file="finbin")
6611	! write(97) u_seri,v_seri,t_seri,q_seri
6612	! close(97)
6613	!$OMP MASTER
6614	if (read_climoz >= 1) then
6615	if (is_mpi_root) then
6616	call nf95_close(ncid_climoz)
6617	end if
6618	deallocate(press_climoz) ! pointer
6619	end if
6620	!$OMP END MASTER
6621	ENDIF
6622
6623	! first=.false.
6624
6625
6626	END SUBROUTINE physiq
6627
6628	END MODULE physiq_mod

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

Download in other formats:

Original Format