Context Navigation

physiq.F @ 391

Last change on this file since 391 was 391, checked in by lmdzadmin, 22 years ago
Modifs sur les sorties demandees par JLD LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 130.9 KB

Line
1	c
2	c $Header$
3	c
4	SUBROUTINE physiq (nlon,nlev,nqmax ,
5	. debut,lafin,rjourvrai,rjour_ecri,gmtime,pdtphys,
6	. paprs,pplay,pphi,pphis,paire,presnivs,clesphy0,
7	. u,v,t,qx,
8	. omega, cufi, cvfi,
9	. d_u, d_v, d_t, d_qx, d_ps)
10	USE ioipsl
11	USE histcom
12	USE writephys
13
14	IMPLICIT none
15	c======================================================================
16	c
17	c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
18	c
19	c Objet: Moniteur general de la physique du modele
20	cAA Modifications quant aux traceurs :
21	cAA - uniformisation des parametrisations ds phytrac
22	cAA - stockage des moyennes des champs necessaires
23	cAA en mode traceur off-line
24	c======================================================================
25	c modif ( P. Le Van , 12/10/98 )
26	c
27	c Arguments:
28	c
29	c nlon----input-I-nombre de points horizontaux
30	c nlev----input-I-nombre de couches verticales
31	c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1
32	c debut---input-L-variable logique indiquant le premier passage
33	c lafin---input-L-variable logique indiquant le dernier passage
34	c rjour---input-R-numero du jour de l'experience
35	c gmtime--input-R-temps universel dans la journee (0 a 86400 s)
36	c pdtphys-input-R-pas d'integration pour la physique (seconde)
37	c paprs---input-R-pression pour chaque inter-couche (en Pa)
38	c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
39	c pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
40	c pphis---input-R-geopotentiel du sol
41	c paire---input-R-aire de chaque maille
42	c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
43	c u-------input-R-vitesse dans la direction X (de O a E) en m/s
44	c v-------input-R-vitesse Y (de S a N) en m/s
45	c t-------input-R-temperature (K)
46	c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
47	c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
48	c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
49	c omega---input-R-vitesse verticale en Pa/s
50	c cufi----input-R-resolution des mailles en x (m)
51	c cvfi----input-R-resolution des mailles en y (m)
52	c
53	c d_u-----output-R-tendance physique de "u" (m/s/s)
54	c d_v-----output-R-tendance physique de "v" (m/s/s)
55	c d_t-----output-R-tendance physique de "t" (K/s)
56	c d_qx----output-R-tendance physique de "qx" (kg/kg/s)
57	c d_ps----output-R-tendance physique de la pression au sol
58	c======================================================================
59	#include "dimensions.h"
60	integer jjmp1
61	parameter (jjmp1=jjm+1-1/jjm)
62	#include "dimphy.h"
63	#include "regdim.h"
64	#include "indicesol.h"
65	#include "dimsoil.h"
66	#include "clesphys.h"
67	#include "control.h"
68	#include "temps.h"
69	c======================================================================
70	LOGICAL check ! Verifier la conservation du modele en eau
71	PARAMETER (check=.FALSE.)
72	LOGICAL ok_stratus ! Ajouter artificiellement les stratus
73	PARAMETER (ok_stratus=.FALSE.)
74	c======================================================================
75	c Parametres lies au coupleur OASIS:
76	#include "oasis.h"
77	INTEGER,SAVE :: npas, nexca
78	logical rnpb
79	parameter(rnpb=.true.)
80	c PARAMETER (npas=1440)
81	c PARAMETER (nexca=48)
82	EXTERNAL fromcpl, intocpl, inicma
83	c ocean = type de modele ocean a utiliser: force, slab, couple
84	character*6 ocean
85	SAVE ocean
86
87	c parameter (ocean = 'force ')
88	c parameter (ocean = 'couple')
89	logical ok_ocean
90	c======================================================================
91	c Clef controlant l'activation du cycle diurne:
92	ccc LOGICAL cycle_diurne
93	ccc PARAMETER (cycle_diurne=.FALSE.)
94	c======================================================================
95	c Modele thermique du sol, a activer pour le cycle diurne:
96	ccc LOGICAL soil_model
97	ccc PARAMETER (soil_model=.FALSE.)
98	logical ok_veget
99	save ok_veget
100	c parameter (ok_veget = .true.)
101	c parameter (ok_veget = .false.)
102	c======================================================================
103	c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
104	c le calcul du rayonnement est celle apres la precipitation des nuages.
105	c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
106	c la condensation et la precipitation. Cette cle augmente les impacts
107	c radiatifs des nuages.
108	ccc LOGICAL new_oliq
109	ccc PARAMETER (new_oliq=.FALSE.)
110	c======================================================================
111	c Clefs controlant deux parametrisations de l'orographie:
112	cc LOGICAL ok_orodr
113	ccc PARAMETER (ok_orodr=.FALSE.)
114	ccc LOGICAL ok_orolf
115	ccc PARAMETER (ok_orolf=.FALSE.)
116	c======================================================================
117	LOGICAL ok_journe ! sortir le fichier journalier
118	save ok_journe
119	c PARAMETER (ok_journe=.true.)
120	c
121	LOGICAL ok_mensuel ! sortir le fichier mensuel
122	save ok_mensuel
123	c PARAMETER (ok_mensuel=.true.)
124	c
125	LOGICAL ok_instan ! sortir le fichier instantane
126	save ok_instan
127	c PARAMETER (ok_instan=.true.)
128	c
129	LOGICAL ok_region ! sortir le fichier regional
130	PARAMETER (ok_region=.FALSE.)
131	c======================================================================
132	c
133	INTEGER ivap ! indice de traceurs pour vapeur d'eau
134	PARAMETER (ivap=1)
135	INTEGER iliq ! indice de traceurs pour eau liquide
136	PARAMETER (iliq=2)
137
138	INTEGER nvm ! nombre de vegetations
139	PARAMETER (nvm=8)
140	REAL veget(klon,nvm) ! couverture vegetale
141	SAVE veget
142
143	c
144	c
145	c Variables argument:
146	c
147	INTEGER nlon
148	INTEGER nlev
149	INTEGER nqmax
150	REAL rjourvrai, rjour_ecri
151	REAL gmtime
152	REAL pdtphys
153	LOGICAL debut, lafin
154	REAL paprs(klon,klev+1)
155	REAL pplay(klon,klev)
156	REAL pphi(klon,klev)
157	REAL pphis(klon)
158	REAL paire(klon)
159	REAL presnivs(klev)
160	REAL znivsig(klev)
161	REAL zsurf(nbsrf)
162	real cufi(klon), cvfi(klon)
163
164	REAL u(klon,klev)
165	REAL v(klon,klev)
166	REAL t(klon,klev)
167	REAL qx(klon,klev,nqmax)
168
169	REAL t_ancien(klon,klev), q_ancien(klon,klev)
170	SAVE t_ancien, q_ancien
171	LOGICAL ancien_ok
172	SAVE ancien_ok
173
174	REAL d_t_dyn(klon,klev)
175	REAL d_q_dyn(klon,klev)
176
177	REAL omega(klon,klev)
178
179	REAL d_u(klon,klev)
180	REAL d_v(klon,klev)
181	REAL d_t(klon,klev)
182	REAL d_qx(klon,klev,nqmax)
183	REAL d_ps(klon)
184
185	INTEGER longcles
186	PARAMETER ( longcles = 20 )
187	REAL clesphy0( longcles )
188	c
189	c Variables quasi-arguments
190	c
191	REAL xjour
192	SAVE xjour
193	c
194	c
195	c Variables propres a la physique
196	c
197	REAL dtime
198	SAVE dtime ! pas temporel de la physique
199	c
200	INTEGER radpas
201	SAVE radpas ! frequence d'appel rayonnement
202	c
203	REAL radsol(klon)
204	SAVE radsol ! bilan radiatif au sol
205	c
206	REAL rlat(klon)
207	SAVE rlat ! latitude pour chaque point
208	c
209	REAL rlon(klon)
210	SAVE rlon ! longitude pour chaque point
211	c
212	cc INTEGER iflag_con
213	cc SAVE iflag_con ! indicateur de la convection
214	c
215	INTEGER itap
216	SAVE itap ! compteur pour la physique
217	c
218	REAL co2_ppm
219	SAVE co2_ppm ! concentration du CO2
220	c
221	REAL solaire
222	SAVE solaire ! constante solaire
223	c
224	REAL ftsol(klon,nbsrf)
225	SAVE ftsol ! temperature du sol
226	c
227	REAL ftsoil(klon,nsoilmx,nbsrf)
228	SAVE ftsoil ! temperature dans le sol
229	c
230	REAL fevap(klon,nbsrf)
231	SAVE fevap ! evaporation
232	REAL fluxlat(klon,nbsrf)
233	SAVE fluxlat
234	c
235	REAL deltat(klon)
236	SAVE deltat ! ecart avec la SST de reference
237	c
238	REAL fqsol(klon,nbsrf)
239	SAVE fqsol ! humidite du sol
240	c
241	REAL fsnow(klon,nbsrf)
242	SAVE fsnow ! epaisseur neigeuse
243	c
244	REAL falbe(klon,nbsrf)
245	SAVE falbe ! albedo par type de surface
246	REAL falblw(klon,nbsrf)
247	SAVE falblw ! albedo par type de surface
248
249	c
250	c
251	c Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
252	c
253	REAL zmea(klon)
254	SAVE zmea ! orographie moyenne
255	c
256	REAL zstd(klon)
257	SAVE zstd ! deviation standard de l'OESM
258	c
259	REAL zsig(klon)
260	SAVE zsig ! pente de l'OESM
261	c
262	REAL zgam(klon)
263	save zgam ! anisotropie de l'OESM
264	c
265	REAL zthe(klon)
266	SAVE zthe ! orientation de l'OESM
267	c
268	REAL zpic(klon)
269	SAVE zpic ! Maximum de l'OESM
270	c
271	REAL zval(klon)
272	SAVE zval ! Minimum de l'OESM
273	c
274	REAL rugoro(klon)
275	SAVE rugoro ! longueur de rugosite de l'OESM
276	c
277	REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
278	c
279	REAL zuthe(klon),zvthe(klon)
280	SAVE zuthe
281	SAVE zvthe
282	INTEGER igwd,idx(klon),itest(klon)
283	c
284	REAL agesno(klon,nbsrf)
285	SAVE agesno ! age de la neige
286	c
287	REAL alb_neig(klon)
288	SAVE alb_neig ! albedo de la neige
289	cKE43
290	c Variables liees a la convection de K. Emanuel (sb):
291	c
292	REAL ema_workcbmf(klon) ! cloud base mass flux
293	SAVE ema_workcbmf
294
295	REAL ema_cbmf(klon) ! cloud base mass flux
296	SAVE ema_cbmf
297
298	REAL ema_pcb(klon) ! cloud base pressure
299	SAVE ema_pcb
300
301	REAL ema_pct(klon) ! cloud top pressure
302	SAVE ema_pct
303
304	REAL bas, top ! cloud base and top levels
305	SAVE bas
306	SAVE top
307
308	REAL Ma(klon,klev) ! undilute upward mass flux
309	SAVE Ma
310	REAL ema_work1(klon, klev), ema_work2(klon, klev)
311	SAVE ema_work1, ema_work2
312	REAL wdn(klon), tdn(klon), qdn(klon)
313	c Variables locales pour la couche limite (al1):
314	c
315	cAl1 REAL pblh(klon) ! Hauteur de couche limite
316	cAl1 SAVE pblh
317	c34EK
318	c
319	c Variables locales:
320	c
321	REAL cdragh(klon) ! drag coefficient pour T and Q
322	REAL cdragm(klon) ! drag coefficient pour vent
323	cAA
324	cAA Pour phytrac
325	cAA
326	REAL ycoefh(klon,klev) ! coef d'echange pour phytrac
327	REAL yu1(klon) ! vents dans la premiere couche U
328	REAL yv1(klon) ! vents dans la premiere couche V
329	LOGICAL offline ! Controle du stockage ds "physique"
330	PARAMETER (offline=.false.)
331	INTEGER physid
332	REAL pfrac_impa(klon,klev)! Produits des coefs lessivage impaction
333	save pfrac_impa
334	REAL pfrac_nucl(klon,klev)! Produits des coefs lessivage nucleation
335	save pfrac_nucl
336	REAL pfrac_1nucl(klon,klev)! Produits des coefs lessi nucl (alpha = 1)
337	save pfrac_1nucl
338	REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
339	REAL frac_nucl(klon,klev) ! idem (nucleation)
340	cAA
341	REAL rain_fall(klon) ! pluie
342	REAL snow_fall(klon) ! neige
343	save snow_fall, rain_fall
344	REAL evap(klon), devap(klon) ! evaporation et sa derivee
345	REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
346	REAL dlw(klon) ! derivee infra rouge
347	REAL bils(klon) ! bilan de chaleur au sol
348	REAL fder(klon) ! Derive de flux (sensible et latente)
349	save fder
350	REAL ve(klon) ! integr. verticale du transport meri. de l'energie
351	REAL vq(klon) ! integr. verticale du transport meri. de l'eau
352	REAL ue(klon) ! integr. verticale du transport zonal de l'energie
353	REAL uq(klon) ! integr. verticale du transport zonal de l'eau
354	c
355	REAL frugs(klon,nbsrf) ! longueur de rugosite
356	save frugs
357	REAL zxrugs(klon) ! longueur de rugosite
358	c
359	c Conditions aux limites
360	c
361	INTEGER julien
362	c
363	INTEGER lmt_pas
364	SAVE lmt_pas ! frequence de mise a jour
365	REAL pctsrf(klon,nbsrf)
366	SAVE pctsrf ! sous-fraction du sol
367	REAL albsol(klon)
368	SAVE albsol ! albedo du sol total
369	REAL albsollw(klon)
370	SAVE albsollw ! albedo du sol total
371	REAL albsol1(klon)
372	SAVE albsol1 ! albedo du sol total
373	REAL albsollw1(klon)
374	SAVE albsollw1 ! albedo du sol total
375
376	REAL wo(klon,klev)
377	SAVE wo ! ozone
378	c======================================================================
379	c
380	c Declaration des procedures appelees
381	c
382	EXTERNAL angle ! calculer angle zenithal du soleil
383	EXTERNAL alboc ! calculer l'albedo sur ocean
384	EXTERNAL albsno ! calculer albedo sur neige
385	EXTERNAL ajsec ! ajustement sec
386	EXTERNAL clmain ! couche limite
387	EXTERNAL condsurf ! lire les conditions aux limites
388	EXTERNAL conlmd ! convection (schema LMD)
389	cKE43
390	EXTERNAL conema3 ! convect4.3
391	EXTERNAL fisrtilp ! schema de condensation a grande echelle (pluie)
392	cAA
393	EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
394	c ! stockage des coefficients necessaires au
395	c ! lessivage OFF-LINE et ON-LINE
396	cAA
397	EXTERNAL hgardfou ! verifier les temperatures
398	EXTERNAL nuage ! calculer les proprietes radiatives
399	EXTERNAL o3cm ! initialiser l'ozone
400	EXTERNAL orbite ! calculer l'orbite terrestre
401	EXTERNAL ozonecm ! prescrire l'ozone
402	EXTERNAL phyetat0 ! lire l'etat initial de la physique
403	EXTERNAL phyredem ! ecrire l'etat de redemarrage de la physique
404	EXTERNAL radlwsw ! rayonnements solaire et infrarouge
405	EXTERNAL suphec ! initialiser certaines constantes
406	EXTERNAL transp ! transport total de l'eau et de l'energie
407	EXTERNAL ecribina ! ecrire le fichier binaire global
408	EXTERNAL ecribins ! ecrire le fichier binaire global
409	EXTERNAL ecrirega ! ecrire le fichier binaire regional
410	EXTERNAL ecriregs ! ecrire le fichier binaire regional
411	c
412	c Variables locales
413	c
414	real clwcon(klon,klev),rnebcon(klon,klev)
415	real clwcon0(klon,klev),rnebcon0(klon,klev)
416	save rnebcon, clwcon
417
418	REAL rhcl(klon,klev) ! humiditi relative ciel clair
419	REAL dialiq(klon,klev) ! eau liquide nuageuse
420	REAL diafra(klon,klev) ! fraction nuageuse
421	REAL cldliq(klon,klev) ! eau liquide nuageuse
422	REAL cldfra(klon,klev) ! fraction nuageuse
423	REAL cldtau(klon,klev) ! epaisseur optique
424	REAL cldemi(klon,klev) ! emissivite infrarouge
425	c
426	C§§§ PB
427	REAL fluxq(klon,klev, nbsrf) ! flux turbulent d'humidite
428	REAL fluxt(klon,klev, nbsrf) ! flux turbulent de chaleur
429	REAL fluxu(klon,klev, nbsrf) ! flux turbulent de vitesse u
430	REAL fluxv(klon,klev, nbsrf) ! flux turbulent de vitesse v
431	c
432	REAL zxfluxt(klon, klev)
433	REAL zxfluxq(klon, klev)
434	REAL zxfluxu(klon, klev)
435	REAL zxfluxv(klon, klev)
436	C§§§
437	REAL heat(klon,klev) ! chauffage solaire
438	REAL heat0(klon,klev) ! chauffage solaire ciel clair
439	REAL cool(klon,klev) ! refroidissement infrarouge
440	REAL cool0(klon,klev) ! refroidissement infrarouge ciel clair
441	REAL topsw(klon), toplw(klon), solsw(klon), sollw(klon)
442	real sollwdown(klon) ! downward LW flux at surface
443	REAL topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
444	REAL albpla(klon)
445	c Le rayonnement n'est pas calcule tous les pas, il faut donc
446	c sauvegarder les sorties du rayonnement
447	SAVE heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
448	SAVE topsw0,toplw0,solsw0,sollw0, heat0, cool0
449	INTEGER itaprad
450	SAVE itaprad
451	c
452	REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
453	REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
454	c
455	REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
456	REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
457	c
458	REAL zxtsol(klon), zxqsol(klon), zxsnow(klon), zxfluxlat(klon)
459	c
460	REAL dist, rmu0(klon), fract(klon)
461	REAL zdtime, zlongi
462	c
463	CHARACTER*2 str2
464	CHARACTER*2 iqn
465	c
466	REAL qcheck
467	REAL z_avant(klon), z_apres(klon), z_factor(klon)
468	LOGICAL zx_ajustq
469	c
470	REAL za, zb
471	REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
472	real zqsat(klon,klev)
473	INTEGER i, k, iq, ig, j, nsrf, ll
474	REAL t_coup
475	PARAMETER (t_coup=234.0)
476	c
477	REAL zphi(klon,klev)
478	REAL zx_tmp_x(iim), zx_tmp_yjjmp1
479	REAL zx_relief(iim,jjmp1)
480	REAL zx_aire(iim,jjmp1)
481	cKE43
482	c Variables locales pour la convection de K. Emanuel (sb):
483	c
484	REAL upwd(klon,klev) ! saturated updraft mass flux
485	REAL dnwd(klon,klev) ! saturated downdraft mass flux
486	REAL dnwd0(klon,klev) ! unsaturated downdraft mass flux
487	REAL tvp(klon,klev) ! virtual temp of lifted parcel
488	REAL cape(klon) ! CAPE
489	SAVE cape
490	REAL pbase(klon) ! cloud base pressure
491	SAVE pbase
492	REAL bbase(klon) ! cloud base buoyancy
493	SAVE bbase
494	REAL rflag(klon) ! flag fonctionnement de convect
495	INTEGER iflagctrl(klon) ! flag fonctionnement de convect
496	c -- convect43:
497	INTEGER ntra ! nb traceurs pour convect4.3
498	REAL pori_con(klon) ! pressure at the origin level of lifted parcel
499	REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon)
500	REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
501	REAL dplcldt(klon), dplcldr(klon)
502	c? . condm_con(klon,klev),conda_con(klon,klev),
503	c? . mr_con(klon,klev),ep_con(klon,klev)
504	c? . ,sadiab(klon,klev),wadiab(klon,klev)
505	c --
506	c34EK
507	c
508	c Variables du changement
509	c
510	c con: convection
511	c lsc: condensation a grande echelle (Large-Scale-Condensation)
512	c ajs: ajustement sec
513	c eva: evaporation de l'eau liquide nuageuse
514	c vdf: couche limite (Vertical DiFfusion)
515	REAL d_t_con(klon,klev),d_q_con(klon,klev)
516	REAL d_u_con(klon,klev),d_v_con(klon,klev)
517	REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev)
518	REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
519	REAL d_t_eva(klon,klev),d_q_eva(klon,klev)
520	REAL rneb(klon,klev)
521	c
522	REAL pmfu(klon,klev), pmfd(klon,klev)
523	REAL pen_u(klon,klev), pen_d(klon,klev)
524	REAL pde_u(klon,klev), pde_d(klon,klev)
525	INTEGER kcbot(klon), kctop(klon), kdtop(klon)
526	REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
527	REAL prfl(klon,klev+1), psfl(klon,klev+1)
528	c
529	INTEGER ibas_con(klon), itop_con(klon)
530	REAL rain_con(klon), rain_lsc(klon)
531	REAL snow_con(klon), snow_lsc(klon)
532	REAL d_ts(klon,nbsrf)
533	c
534	REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev)
535	REAL d_t_vdf(klon,klev), d_q_vdf(klon,klev)
536	c
537	REAL d_u_oro(klon,klev), d_v_oro(klon,klev)
538	REAL d_t_oro(klon,klev)
539	REAL d_u_lif(klon,klev), d_v_lif(klon,klev)
540	REAL d_t_lif(klon,klev)
541
542	REAL ratqs(klon,klev),ratqss(klon,klev),ratqsc(klon,klev)
543	real ratqsbas,ratqshaut
544	save ratqsbas,ratqshaut, ratqs
545	real zpt_conv(klon,klev)
546
547	c Parametres lies au nouveau schema de nuages (SB, PDF)
548	real fact_cldcon
549	real facttemps
550	logical ok_newmicro
551	save ok_newmicro
552	save fact_cldcon,facttemps
553	real facteur
554
555	integer iflag_cldcon
556	save iflag_cldcon
557
558	logical ptconv(klon,klev)
559
560	c
561	c Variables liees a l'ecriture de la bande histoire physique
562	c
563	INTEGER ecrit_mth
564	SAVE ecrit_mth ! frequence d'ecriture (fichier mensuel)
565	c
566	INTEGER ecrit_day
567	SAVE ecrit_day ! frequence d'ecriture (fichier journalier)
568	c
569	INTEGER ecrit_ins
570	SAVE ecrit_ins ! frequence d'ecriture (fichier instantane)
571	c
572	INTEGER ecrit_reg
573	SAVE ecrit_reg ! frequence d'ecriture
574	c
575	integer itau_w ! pas de temps ecriture = itap + itau_phy
576	c
577	c
578	c Variables locales pour effectuer les appels en serie
579	c
580	REAL t_seri(klon,klev), q_seri(klon,klev)
581	REAL ql_seri(klon,klev),qs_seri(klon,klev)
582	REAL u_seri(klon,klev), v_seri(klon,klev)
583	c
584	REAL tr_seri(klon,klev,nbtr)
585	REAL d_tr(klon,klev,nbtr)
586
587	REAL zx_rh(klon,klev)
588
589	INTEGER length
590	PARAMETER ( length = 100 )
591	REAL tabcntr0( length )
592	c
593	INTEGER ndex2d(iimjjmp1),ndex3d(iimjjmp1*klev)
594	REAL zx_tmp_fi2d(klon)
595	REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
596	REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
597	c
598	INTEGER nid_day, nid_mth, nid_ins
599	SAVE nid_day, nid_mth, nid_ins
600	c
601	INTEGER nhori, nvert
602	REAL zsto, zout
603	real zjulian
604	save zjulian
605
606	character*20 modname
607	character*80 abort_message
608	logical ok_sync
609	real date0
610	integer idayref
611
612	C essai writephys
613	integer fid_day, fid_mth, fid_ins
614	parameter (fid_ins = 1, fid_day = 2, fid_mth = 3)
615	integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
616	parameter (prof2d_on = 1, prof3d_on = 2,
617	. prof2d_av = 3, prof3d_av = 4)
618	character*30 nom_fichier
619	character*10 varname
620	character*40 vartitle
621	character*20 varunits
622	C Variables liees au bilan d'energie et d'enthalpi
623	INTEGER if_ebil ! level for energy conserv. dignostics
624	SAVE if_ebil
625	REAL ztsol(klon)
626	REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
627	$ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
628	SAVE h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
629	$ , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
630	REAL d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
631	REAL d_h_vcol_phy
632	REAL fs_bound, fq_bound
633	SAVE d_h_vcol_phy
634	REAL zero_v(klon)
635	CHARACTER*15 ztit
636	INTEGER ip_ebil ! PRINT level for energy conserv. diag.
637	SAVE ip_ebil
638	DATA ip_ebil/2/
639	c
640	c Declaration des constantes et des fonctions thermodynamiques
641	c
642	#include "YOMCST.h"
643	#include "YOETHF.h"
644	#include "FCTTRE.h"
645	c======================================================================
646	modname = 'physiq'
647	if_ebil = 2
648	IF (if_ebil.ge.1) THEN
649	DO i=1,klon
650	zero_v(i)=0.
651	END DO
652	END IF
653	ok_sync=.TRUE.
654	IF (nqmax .LT. 2) THEN
655	PRINT*, 'eaux vapeur et liquide sont indispensables'
656	CALL ABORT
657	ENDIF
658	IF (debut) THEN
659	CALL suphec ! initialiser constantes et parametres phys.
660	ENDIF
661
662
663	c======================================================================
664	xjour = rjourvrai
665	c
666	c Si c'est le debut, il faut initialiser plusieurs choses
667	c ********
668	c
669	IF (debut) THEN
670	C
671	IF (if_ebil.ge.1) d_h_vcol_phy=0.
672	c
673	c appel a la lecture du run.def physique
674	c
675	call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
676	. ok_instan, fact_cldcon, facttemps,ok_newmicro,
677	. iflag_cldcon,ratqsbas,ratqshaut)
678
679	DO k = 2, nvm ! pas de vegetation
680	DO i = 1, klon
681	veget(i,k) = 0.0
682	ENDDO
683	ENDDO
684	DO i = 1, klon
685	veget(i,1) = 1.0 ! il n'y a que du desert
686	ENDDO
687	PRINT*, 'Pas de vegetation; desert partout'
688	c
689	c
690	c Initialiser les compteurs:
691	c
692
693	frugs = 0.
694	itap = 0
695	itaprad = 0
696	c
697	CALL phyetat0 ("startphy.nc",dtime,co2_ppm,solaire,
698	. rlat,rlon,pctsrf, ftsol,ftsoil,deltat,fqsol,fsnow,
699	. falbe, fevap, rain_fall,snow_fall,solsw, sollwdown,
700	. dlw,radsol,frugs,agesno,clesphy0,
701	. zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0,
702	. t_ancien, q_ancien, ancien_ok, rnebcon, ratqs,clwcon )
703
704	c
705	radpas = NINT( 86400./dtime/nbapp_rad)
706
707	c
708	CALL printflag( tabcntr0,radpas,ok_ocean,ok_oasis ,ok_journe,
709	, ok_instan, ok_region )
710	c
711	IF (ABS(dtime-pdtphys).GT.0.001) THEN
712	PRINT*, 'Pas physique n est pas correcte',dtime,pdtphys
713	abort_message=' See above '
714	call abort_gcm(modname,abort_message,1)
715	ENDIF
716	IF (nlon .NE. klon) THEN
717	PRINT*, 'nlon et klon ne sont pas coherents', nlon, klon
718	abort_message=' See above '
719	call abort_gcm(modname,abort_message,1)
720	ENDIF
721	IF (nlev .NE. klev) THEN
722	PRINT*, 'nlev et klev ne sont pas coherents', nlev, klev
723	abort_message=' See above '
724	call abort_gcm(modname,abort_message,1)
725	ENDIF
726	c
727	IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN
728	PRINT*, 'Nbre d appels au rayonnement insuffisant'
729	PRINT*, "Au minimum 4 appels par jour si cycle diurne"
730	abort_message=' See above '
731	call abort_gcm(modname,abort_message,1)
732	ENDIF
733	PRINT*, "Clef pour la convection, iflag_con=", iflag_con
734	c
735	cKE43
736	c Initialisation pour la convection de K.E. (sb):
737	IF (iflag_con.GE.3) THEN
738
739	PRINT, "** Convection de Kerry Emanuel 4.3 "
740	PRINT*, "On va utiliser le melange convectif des traceurs qui"
741	PRINT*, "est calcule dans convect4.3"
742	PRINT*, " !!! penser aux logical flags de phytrac"
743
744	DO i = 1, klon
745	ema_cbmf(i) = 0.
746	ema_pcb(i) = 0.
747	ema_pct(i) = 0.
748	ema_workcbmf(i) = 0.
749	ENDDO
750	ENDIF
751	c34EK
752	IF (ok_orodr) THEN
753	DO i=1,klon
754	rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
755	ENDDO
756	CALL SUGWD(klon,klev,paprs,pplay)
757	DO i=1,klon
758	zuthe(i)=0.
759	zvthe(i)=0.
760	if(zstd(i).gt.10.)then
761	zuthe(i)=(1.-zgam(i))*cos(zthe(i))
762	zvthe(i)=(1.-zgam(i))*sin(zthe(i))
763	endif
764	ENDDO
765	ENDIF
766	c
767	c
768	lmt_pas = NINT(86400./dtime * 1.0) ! tous les jours
769	PRINT*,'La frequence de lecture surface est de ', lmt_pas
770	c
771	ecrit_mth = NINT(86400./dtime *ecritphy) ! tous les ecritphy jours
772	IF (ok_mensuel) THEN
773	PRINT*, 'La frequence de sortie mensuelle est de ', ecrit_mth
774	ENDIF
775	ecrit_day = NINT(86400./dtime *1.0) ! tous les jours
776	IF (ok_journe) THEN
777	PRINT*, 'La frequence de sortie journaliere est de ',ecrit_day
778	ENDIF
779	ccc ecrit_ins = NINT(86400./dtime *0.5) ! 2 fois par jour
780	ccc ecrit_ins = NINT(86400./dtime *0.25) ! 4 fois par jour
781	ecrit_ins = NINT(86400./dtime/12.) ! toutes les deux heures
782	ecrit_ins = NINT(86400./dtime/48.) ! a chaque pas de temps
783	IF (ok_instan) THEN
784	PRINT*, 'La frequence de sortie instant. est de ', ecrit_ins
785	ENDIF
786	ecrit_reg = NINT(86400./dtime *0.25) ! 4 fois par jour
787	IF (ok_region) THEN
788	PRINT*, 'La frequence de sortie region est de ', ecrit_reg
789	ENDIF
790
791	c
792	c Initialiser le couplage si necessaire
793	c
794	npas = 0
795	nexca = 0
796	if (ocean == 'couple') then
797	npas = itaufin/ iphysiq
798	nexca = 86400 / dtime
799	write(,)' ##### Ocean couple #####'
800	write(,)' Valeurs des pas de temps'
801	write(,)' npas = ', npas
802	write(,)' nexca = ', nexca
803	endif
804	c
805	c
806	c Gestion calendrier
807
808	c
809	IF (ok_journe) THEN
810	c
811	idayref = day_ref
812	CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
813	c
814	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
815	DO i = 1, iim
816	zx_lon(i,1) = rlon(i+1)
817	zx_lon(i,jjmp1) = rlon(i+1)
818	ENDDO
819	DO ll=1,klev
820	znivsig(ll)=float(ll)
821	ENDDO
822	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
823	write(,)'zx_lon = ',zx_lon(:,1)
824	write(,)'zx_lat = ',zx_lat(1,:)
825	CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
826	. 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
827	. nhori, nid_day)
828	write(,)'Journee ', itau_phy, zjulian
829	CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
830	. klev, presnivs, nvert)
831	c call histvert(nid_day, 'sig_s', 'Niveaux sigma','-',
832	c . klev, znivsig, nvert)
833	c
834	zsto = dtime
835	zout = dtime * FLOAT(ecrit_day)
836	C Essai writephys
837	c nom_fichier = 'histday1'
838	c call writephy_ini(fid_day,nom_fichier,klon,iim,jjmp1,klev,
839	c . rlon,rlat, presnivs,
840	c . zjulian, dtime)
841	c call writephy_def(prof2d_on, fid_day, "once", zsto, zout, 0)
842	c call writephy_def(prof3d_on, fid_day, "once", zsto, zout,
843	c . klev)
844	c call writephy_def(prof2d_av, fid_day, "ave(X)", zsto, zout, 0)
845	c call writephy_def(prof3d_av, fid_day, "ave(X)", zsto, zout,
846	c . klev)
847
848	c
849	CALL histdef(nid_day, "phis", "Surface geop. height", "-",
850	. iim,jjmp1,nhori, 1,1,1, -99, 32,
851	. "once", zsto,zout)
852	c
853	CALL histdef(nid_day, "aire", "Grid area", "-",
854	. iim,jjmp1,nhori, 1,1,1, -99, 32,
855	. "once", zsto,zout)
856	c
857	c Champs 2D:
858	c
859	CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
860	. iim,jjmp1,nhori, 1,1,1, -99, 32,
861	. "ave(X)", zsto,zout)
862	c
863	CALL histdef(nid_day, "tter", "Surface Temperature", "K",
864	. iim,jjmp1,nhori, 1,1,1, -99, 32,
865	. "ave(X)", zsto,zout)
866	c
867	CALL histdef(nid_day, "tlic", "Surface Temperature", "K",
868	. iim,jjmp1,nhori, 1,1,1, -99, 32,
869	. "ave(X)", zsto,zout)
870	c
871	CALL histdef(nid_day, "toce", "Surface Temperature", "K",
872	. iim,jjmp1,nhori, 1,1,1, -99, 32,
873	. "ave(X)", zsto,zout)
874	c
875	CALL histdef(nid_day, "tsic", "Surface Temperature", "K",
876	. iim,jjmp1,nhori, 1,1,1, -99, 32,
877	. "ave(X)", zsto,zout)
878	c
879	CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
880	. iim,jjmp1,nhori, 1,1,1, -99, 32,
881	. "ave(X)", zsto,zout)
882	c
883	CALL histdef(nid_day, "rain","Precipitation Totale liq+sol"
884	. , "kg/s",
885	. iim,jjmp1,nhori, 1,1,1, -99, 32,
886	. "ave(X)", zsto,zout)
887	c
888	CALL histdef(nid_day, "snow", "Snow fall", "kg/s",
889	. iim,jjmp1,nhori, 1,1,1, -99, 32,
890	. "ave(X)", zsto,zout)
891	c
892	CALL histdef(nid_day, "snow_cov", "Snow cover", "mm",
893	. iim,jjmp1,nhori, 1,1,1, -99, 32,
894	. "ave(X)", zsto,zout)
895	c
896	CALL histdef(nid_day, "evap", "Evaporation", "kg/s",
897	. iim,jjmp1,nhori, 1,1,1, -99, 32,
898	. "ave(X)", zsto,zout)
899	c
900	CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
901	. iim,jjmp1,nhori, 1,1,1, -99, 32,
902	. "ave(X)", zsto,zout)
903	c
904	CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
905	. iim,jjmp1,nhori, 1,1,1, -99, 32,
906	. "ave(X)", zsto,zout)
907	c
908	CALL histdef(nid_day, "sols", "Net Solar rad. at surf.",
909	. "W/m2",
910	. iim,jjmp1,nhori, 1,1,1, -99, 32,
911	. "ave(X)", zsto,zout)
912	c
913	CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2",
914	. iim,jjmp1,nhori, 1,1,1, -99, 32,
915	. "ave(X)", zsto,zout)
916	c
917	CALL histdef(nid_day, "solldown", "Down. IR rad. at surface",
918	. "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32,
919	. "ave(X)", zsto,zout)
920	c
921	CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
922	. iim,jjmp1,nhori, 1,1,1, -99, 32,
923	. "ave(X)", zsto,zout)
924	c
925	CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
926	. iim,jjmp1,nhori, 1,1,1, -99, 32,
927	. "ave(X)", zsto,zout)
928	c
929	CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2",
930	. iim,jjmp1,nhori, 1,1,1, -99, 32,
931	. "ave(X)", zsto,zout)
932	c
933	CALL histdef(nid_day, "frtu", "Zonal wind stress", "Pa",
934	. iim,jjmp1,nhori, 1,1,1, -99, 32,
935	. "ave(X)", zsto,zout)
936	c
937	CALL histdef(nid_day, "frtv", "Meridional wind stress", "Pa",
938	. iim,jjmp1,nhori, 1,1,1, -99, 32,
939	. "ave(X)", zsto,zout)
940	c
941	C §§§ PB flux pour chauqe sous surface
942	C
943	DO nsrf = 1, nbsrf
944	C
945	call histdef(nid_day, "pourc_"//clnsurf(nsrf),
946	$ "Fraction"//clnsurf(nsrf), "W/m2",
947	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
948	$ "ave(X)", zsto,zout)
949	C
950	call histdef(nid_day, "tsol_"//clnsurf(nsrf),
951	$ "Fraction"//clnsurf(nsrf), "W/m2",
952	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
953	$ "ave(X)", zsto,zout)
954	C
955	call histdef(nid_day, "sens_"//clnsurf(nsrf),
956	$ "Sensible heat flux "//clnsurf(nsrf), "W/m2",
957	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
958	$ "ave(X)", zsto,zout)
959	c
960	call histdef(nid_day, "lat_"//clnsurf(nsrf),
961	$ "Latent heat flux "//clnsurf(nsrf), "W/m2",
962	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
963	$ "ave(X)", zsto,zout)
964	C
965	call histdef(nid_day, "taux_"//clnsurf(nsrf),
966	$ "Zonal wind stress"//clnsurf(nsrf),"Pa",
967	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
968	$ "ave(X)", zsto,zout)
969
970	call histdef(nid_day, "tauy_"//clnsurf(nsrf),
971	$ "Meridional xind stress "//clnsurf(nsrf), "Pa",
972	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
973	$ "ave(X)", zsto,zout)
974	C
975	call histdef(nid_day, "albe_"//clnsurf(nsrf),
976	$ "Albedo surf. "//clnsurf(nsrf), "W/m2",
977	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
978	$ "ave(X)", zsto,zout)
979	C
980	call histdef(nid_day, "rugs_"//clnsurf(nsrf),
981	$ "Latent heat flux "//clnsurf(nsrf), "W/m2",
982	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
983	$ "ave(X)", zsto,zout)
984
985	C§§§
986	END DO
987
988	CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
989	. iim,jjmp1,nhori, 1,1,1, -99, 32,
990	. "ave(X)", zsto,zout)
991	c
992	CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
993	. iim,jjmp1,nhori, 1,1,1, -99, 32,
994	. "ave(X)", zsto,zout)
995	c
996	CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
997	. iim,jjmp1,nhori, 1,1,1, -99, 32,
998	. "ave(X)", zsto,zout)
999	c
1000	CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
1001	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1002	. "ave(X)", zsto,zout)
1003	c
1004	CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
1005	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1006	. "ave(X)", zsto,zout)
1007	c
1008	CALL histdef(nid_day, "cldq", "Cloud liquid water path", "-",
1009	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1010	. "ave(X)", zsto,zout)
1011	c
1012	c Champs 3D:
1013	c
1014	CALL histdef(nid_day, "temp", "Air temperature", "K",
1015	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1016	. "ave(X)", zsto,zout)
1017	c
1018	CALL histdef(nid_day, "ovap", "Specific humidity", "Kg/Kg",
1019	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1020	. "ave(X)", zsto,zout)
1021	c
1022	CALL histdef(nid_day, "geop", "Geopotential height", "m",
1023	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1024	. "ave(X)", zsto,zout)
1025	c
1026	CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
1027	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1028	. "ave(X)", zsto,zout)
1029	c
1030	CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
1031	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1032	. "ave(X)", zsto,zout)
1033	c
1034	CALL histdef(nid_day, "vitw", "Vertical wind", "m/s",
1035	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1036	. "ave(X)", zsto,zout)
1037	c
1038	CALL histdef(nid_day, "pres", "Air pressure", "Pa",
1039	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1040	. "ave(X)", zsto,zout)
1041	c
1042	CALL histend(nid_day)
1043	c
1044	ndex2d = 0
1045	ndex3d = 0
1046	c
1047	ENDIF ! fin de test sur ok_journe
1048	c
1049	IF (ok_mensuel) THEN
1050	c
1051	idayref = day_ref
1052	CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
1053	c
1054	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
1055	DO i = 1, iim
1056	zx_lon(i,1) = rlon(i+1)
1057	zx_lon(i,jjmp1) = rlon(i+1)
1058	ENDDO
1059	DO ll=1,klev
1060	znivsig(ll)=float(ll)
1061	ENDDO
1062	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
1063	CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
1064	. 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
1065	. nhori, nid_mth)
1066	write(,)'Mensuel ', itau_phy, zjulian
1067	CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
1068	. klev, presnivs, nvert)
1069	c call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-',
1070	c . klev, znivsig, nvert)
1071	c
1072	zsto = dtime
1073	zout = dtime * ecrit_mth
1074	c
1075	CALL histdef(nid_mth, "phis", "Surface geop. height", "-",
1076	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1077	. "once", zsto,zout)
1078	c
1079	CALL histdef(nid_mth, "aire", "Grid area", "-",
1080	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1081	. "once", zsto,zout)
1082	c
1083	c Champs 2D:
1084	c
1085	CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
1086	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1087	. "ave(X)", zsto,zout)
1088	c
1089	CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
1090	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1091	. "ave(X)", zsto,zout)
1092	c
1093	CALL histdef(nid_mth, "qsol", "Surface humidity", "mm",
1094	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1095	. "ave(X)", zsto,zout)
1096	c
1097	CALL histdef(nid_mth, "rain", "Precipitation Totale liq+sol",
1098	. "kg/s",
1099	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1100	. "ave(X)", zsto,zout)
1101	c
1102	CALL histdef(nid_mth, "plul", "Large-scale Precip.", "kg/s",
1103	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1104	. "ave(X)", zsto,zout)
1105	c
1106	CALL histdef(nid_mth, "pluc", "Convective Precip.", "kg/s",
1107	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1108	. "ave(X)", zsto,zout)
1109	c
1110	CALL histdef(nid_mth, "snow", "Snow fall", "kg/s",
1111	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1112	. "ave(X)", zsto,zout)
1113	c
1114	CALL histdef(nid_mth, "snow_cov", "Snow cover", "mm",
1115	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1116	. "ave(X)", zsto,zout)
1117	c
1118	CALL histdef(nid_mth, "evap", "Evaporation", "kg/s",
1119	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1120	. "ave(X)", zsto,zout)
1121	c
1122	CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
1123	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1124	. "ave(X)", zsto,zout)
1125	c
1126	CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
1127	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1128	. "ave(X)", zsto,zout)
1129	c
1130	CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
1131	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1132	. "ave(X)", zsto,zout)
1133	c
1134	CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
1135	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1136	. "ave(X)", zsto,zout)
1137	c
1138	CALL histdef(nid_mth, "solldown", "Down. IR rad. at surface",
1139	. "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32,
1140	. "ave(X)", zsto,zout)
1141	c
1142	CALL histdef(nid_mth, "tops0", "Solar rad. at TOA", "W/m2",
1143	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1144	. "ave(X)", zsto,zout)
1145	c
1146	CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
1147	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1148	. "ave(X)", zsto,zout)
1149	c
1150	CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
1151	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1152	. "ave(X)", zsto,zout)
1153	c
1154	CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
1155	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1156	. "ave(X)", zsto,zout)
1157	c
1158	CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
1159	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1160	. "ave(X)", zsto,zout)
1161	c
1162	CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
1163	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1164	. "ave(X)", zsto,zout)
1165	c
1166	CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
1167	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1168	. "ave(X)", zsto,zout)
1169	c
1170	CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
1171	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1172	. "ave(X)", zsto,zout)
1173	c
1174	CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
1175	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1176	. "ave(X)", zsto,zout)
1177	c
1178	DO nsrf = 1, nbsrf
1179	C
1180	call histdef(nid_mth, "pourc_"//clnsurf(nsrf),
1181	$ "Fraction "//clnsurf(nsrf), "W/m2",
1182	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1183	$ "ave(X)", zsto,zout)
1184	C
1185	call histdef(nid_mth, "tsol_"//clnsurf(nsrf),
1186	$ "Fraction "//clnsurf(nsrf), "W/m2",
1187	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1188	$ "ave(X)", zsto,zout)
1189	C
1190	call histdef(nid_mth, "sens_"//clnsurf(nsrf),
1191	$ "Sensible heat flux "//clnsurf(nsrf), "W/m2",
1192	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1193	$ "ave(X)", zsto,zout)
1194	c
1195	call histdef(nid_mth, "lat_"//clnsurf(nsrf),
1196	$ "Latent heat flux "//clnsurf(nsrf), "W/m2",
1197	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1198	$ "ave(X)", zsto,zout)
1199	C
1200	call histdef(nid_mth, "taux_"//clnsurf(nsrf),
1201	$ "Zonal wind stress"//clnsurf(nsrf), "Pa",
1202	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1203	$ "ave(X)", zsto,zout)
1204
1205	call histdef(nid_mth, "tauy_"//clnsurf(nsrf),
1206	$ "Meridional xind stress "//clnsurf(nsrf), "Pa",
1207	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1208	$ "ave(X)", zsto,zout)
1209	c
1210	call histdef(nid_mth, "albe_"//clnsurf(nsrf),
1211	$ "Albedo surf. "//clnsurf(nsrf), "W/m2",
1212	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1213	$ "ave(X)", zsto,zout)
1214	c
1215	call histdef(nid_mth, "rugs_"//clnsurf(nsrf),
1216	$ "Latent heat flux "//clnsurf(nsrf), "W/m2",
1217	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1218	$ "ave(X)", zsto,zout)
1219	c
1220	CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
1221	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1222	. "ave(X)", zsto,zout)
1223
1224	END DO
1225	C
1226	CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
1227	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1228	. "ave(X)", zsto,zout)
1229	c
1230	CALL histdef(nid_mth, "albs", "Surface albedo", "-",
1231	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1232	. "ave(X)", zsto,zout)
1233	CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
1234	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1235	. "ave(X)", zsto,zout)
1236	c
1237	CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
1238	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1239	. "ave(X)", zsto,zout)
1240	c
1241	CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
1242	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1243	. "ave(X)", zsto,zout)
1244	c
1245	CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
1246	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1247	. "ave(X)", zsto,zout)
1248	c
1249	CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
1250	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1251	. "ave(X)", zsto,zout)
1252	c
1253	CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
1254	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1255	. "ave(X)", zsto,zout)
1256	c
1257	CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
1258	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1259	. "ave(X)", zsto,zout)
1260	c
1261	CALL histdef(nid_mth, "cldq", "Cloud liquid water path", "-",
1262	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1263	. "ave(X)", zsto,zout)
1264	c
1265	CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
1266	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1267	. "ave(X)", zsto,zout)
1268	c
1269	CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
1270	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1271	. "ave(X)", zsto,zout)
1272	c
1273	CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
1274	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1275	. "ave(X)", zsto,zout)
1276	c
1277	CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
1278	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1279	. "ave(X)", zsto,zout)
1280	cKE43
1281	IF (iflag_con .GE. 3) THEN ! sb
1282	c
1283	CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/Kg",
1284	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1285	. "ave(X)", zsto,zout)
1286	c
1287	CALL histdef(nid_mth, "pbase", "Cld base pressure", "hPa",
1288	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1289	. "ave(X)", zsto,zout)
1290	c
1291	CALL histdef(nid_mth, "ptop", "Cld top pressure", "hPa",
1292	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1293	. "ave(X)", zsto,zout)
1294	c
1295	CALL histdef(nid_mth, "fbase", "Cld base mass flux", "Kg/m2/s",
1296	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1297	. "ave(X)", zsto,zout)
1298	c
1299	c
1300	ENDIF
1301	c34EK
1302	c
1303	c Champs 3D:
1304	c
1305	CALL histdef(nid_mth, "temp", "Air temperature", "K",
1306	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1307	. "ave(X)", zsto,zout)
1308	c
1309	CALL histdef(nid_mth, "ovap", "Specific humidity", "Kg/Kg",
1310	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1311	. "ave(X)", zsto,zout)
1312	c
1313	CALL histdef(nid_mth, "geop", "Geopotential height", "m",
1314	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1315	. "ave(X)", zsto,zout)
1316	c
1317	CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
1318	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1319	. "ave(X)", zsto,zout)
1320	c
1321	CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
1322	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1323	. "ave(X)", zsto,zout)
1324	c
1325	CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s",
1326	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1327	. "ave(X)", zsto,zout)
1328	c
1329	CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
1330	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1331	. "ave(X)", zsto,zout)
1332	c
1333	CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
1334	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1335	. "ave(X)", zsto,zout)
1336	c
1337	CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
1338	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1339	. "ave(X)", zsto,zout)
1340	c
1341	CALL histdef(nid_mth, "oliq", "Liquid water content", "kg/kg",
1342	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1343	. "ave(X)", zsto,zout)
1344	c
1345	CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
1346	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1347	. "ave(X)", zsto,zout)
1348	c
1349	CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "Kg/Kg/s",
1350	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1351	. "ave(X)", zsto,zout)
1352	c
1353	CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
1354	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1355	. "ave(X)", zsto,zout)
1356	c
1357	CALL histdef(nid_mth, "ducon", "Convection du", "m/s2",
1358	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1359	. "ave(X)", zsto,zout)
1360	c
1361	CALL histdef(nid_mth, "dqcon", "Convection dQ", "Kg/Kg/s",
1362	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1363	. "ave(X)", zsto,zout)
1364	c
1365	CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
1366	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1367	. "ave(X)", zsto,zout)
1368	c
1369	CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "Kg/Kg/s",
1370	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1371	. "ave(X)", zsto,zout)
1372	c
1373	CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
1374	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1375	. "ave(X)", zsto,zout)
1376	c
1377	CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
1378	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1379	. "ave(X)", zsto,zout)
1380	c
1381	CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
1382	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1383	. "ave(X)", zsto,zout)
1384	c
1385	CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "Kg/Kg/s",
1386	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1387	. "ave(X)", zsto,zout)
1388
1389	CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
1390	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1391	. "ave(X)", zsto,zout)
1392
1393	CALL histdef(nid_mth, "ratqs", "RATQS"," ",
1394	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1395	. "ave(X)", zsto,zout)
1396
1397	c
1398	CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
1399	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1400	. "ave(X)", zsto,zout)
1401
1402	CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "Kg/Kg/s",
1403	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1404	. "ave(X)", zsto,zout)
1405	c
1406	CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
1407	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1408	. "ave(X)", zsto,zout)
1409	c
1410	CALL histdef(nid_mth, "dtsw0", "SW radiation dT", "K/s",
1411	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1412	. "ave(X)", zsto,zout)
1413	c
1414	CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
1415	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1416	. "ave(X)", zsto,zout)
1417	c
1418	CALL histdef(nid_mth, "dtlw0", "LW radiation dT", "K/s",
1419	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1420	. "ave(X)", zsto,zout)
1421	c
1422	CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
1423	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1424	. "ave(X)", zsto,zout)
1425	c
1426	CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
1427	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1428	. "ave(X)", zsto,zout)
1429	c
1430	IF (ok_orodr) THEN
1431	CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
1432	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1433	. "ave(X)", zsto,zout)
1434	c
1435	CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
1436	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1437	. "ave(X)", zsto,zout)
1438	c
1439	ENDIF
1440	C
1441	IF (ok_orolf) THEN
1442	CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
1443	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1444	. "ave(X)", zsto,zout)
1445	c
1446	CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
1447	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1448	. "ave(X)", zsto,zout)
1449	ENDIF
1450	C
1451	CALL histdef(nid_mth, "ozone", "Ozone concentration", "-",
1452	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1453	. "ave(X)", zsto,zout)
1454	c
1455	if (nqmax.GE.3) THEN
1456	DO iq=1,nqmax-2
1457	IF (iq.LE.99) THEN
1458	WRITE(str2,'(i2.2)') iq
1459	CALL histdef(nid_mth, "trac"//str2, "Tracer No."//str2, "-",
1460	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1461	. "ave(X)", zsto,zout)
1462	ELSE
1463	PRINT*, "Trop de traceurs"
1464	CALL abort
1465	ENDIF
1466	ENDDO
1467	ENDIF
1468	c
1469	cKE43
1470	IF (iflag_con.GE.3) THEN ! (sb)
1471	c
1472	CALL histdef(nid_mth, "upwd", "saturated updraft", "Kg/m2/s",
1473	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1474	. "ave(X)", zsto,zout)
1475	c
1476	CALL histdef(nid_mth, "dnwd", "saturated downdraft","Kg/m2/s",
1477	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1478	. "ave(X)", zsto,zout)
1479	c
1480	CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "Kg/m2/s",
1481	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1482	. "ave(X)", zsto,zout)
1483	c
1484	CALL histdef(nid_mth,"Ma","undilute adiab updraft","Kg/m2/s",
1485	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1486	. "ave(X)", zsto,zout)
1487	c
1488	c
1489	ENDIF
1490	c34EK
1491	CALL histend(nid_mth)
1492	c
1493	ndex2d = 0
1494	ndex3d = 0
1495	c
1496	ENDIF ! fin de test sur ok_mensuel
1497	c
1498	c
1499	IF (ok_instan) THEN
1500	c
1501	idayref = day_ref
1502	CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
1503	c
1504	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
1505	DO i = 1, iim
1506	zx_lon(i,1) = rlon(i+1)
1507	zx_lon(i,jjmp1) = rlon(i+1)
1508	ENDDO
1509	DO ll=1,klev
1510	znivsig(ll)=float(ll)
1511	ENDDO
1512	CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
1513	CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
1514	. 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
1515	. nhori, nid_ins)
1516	write(,)'Inst ', itau_phy, zjulian
1517	CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
1518	. klev, presnivs, nvert)
1519	c call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
1520	c . klev, znivsig, nvert)
1521	c
1522	c
1523	zsto = dtime * ecrit_ins
1524	zout = dtime * ecrit_ins
1525	C
1526	CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
1527	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1528	. "once", zsto,zout)
1529	c
1530	CALL histdef(nid_ins, "aire", "Grid area", "-",
1531	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1532	. "once", zsto,zout)
1533	c
1534	c Champs 2D:
1535	c
1536	CALL histdef(nid_ins, "tsol", "Surface Temperature", "K",
1537	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1538	. "inst(X)", zsto,zout)
1539	c
1540	CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
1541	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1542	. "inst(X)", zsto,zout)
1543	c
1544	CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day",
1545	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1546	. "inst(X)", zsto,zout)
1547	c
1548	CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day",
1549	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1550	. "inst(X)", zsto,zout)
1551
1552	CALL histdef(nid_ins, "qsol", "Surface humidity", "mm",
1553	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1554	. "inst(X)", zsto,zout)
1555	c
1556	CALL histdef(nid_ins, "cdrm", "Momentum drag coef.", "-",
1557	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1558	. "inst(X)", zsto,zout)
1559	c
1560	CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-",
1561	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1562	. "inst(X)", zsto,zout)
1563	c
1564	CALL histdef(nid_ins, "rain", "Precipitation Totale liq+sol",
1565	. "kg/s",
1566	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1567	. "inst(X)", zsto,zout)
1568	c
1569	CALL histdef(nid_ins, "snow", "Snow fall", "kg/s",
1570	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1571	. "inst(X)", zsto,zout)
1572	c
1573	CALL histdef(nid_ins, "snow_cov", "Snow cover", "mm",
1574	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1575	. "inst(X)", zsto,zout)
1576	c
1577	CALL histdef(nid_ins, "topl", "OLR", "W/m2",
1578	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1579	. "inst(X)", zsto,zout)
1580	c
1581	CALL histdef(nid_ins, "evap", "Evaporation", "kg/s",
1582	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1583	. "inst(X)", zsto,zout)
1584	c
1585	CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2",
1586	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1587	. "inst(X)", zsto,zout)
1588	c
1589	CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2",
1590	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1591	. "inst(X)", zsto,zout)
1592	c
1593	CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface",
1594	. "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32,
1595	. "inst(X)", zsto,zout)
1596	c
1597	CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2",
1598	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1599	. "inst(X)", zsto,zout)
1600	c
1601	CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2",
1602	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1603	. "inst(X)", zsto,zout)
1604	c
1605	CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2",
1606	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1607	. "inst(X)", zsto,zout)
1608	c
1609	CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s",
1610	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1611	. "inst(X)", zsto,zout)
1612	c
1613	CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s",
1614	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1615	. "inst(X)", zsto,zout)
1616	c
1617	CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s",
1618	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1619	. "inst(X)", zsto,zout)
1620	c
1621	CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s",
1622	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1623	. "inst(X)", zsto,zout)
1624
1625	DO nsrf = 1, nbsrf
1626	C
1627	call histdef(nid_ins, "pourc_"//clnsurf(nsrf),
1628	$ "Fraction"//clnsurf(nsrf), "W/m2",
1629	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1630	$ "inst(X)", zsto,zout)
1631
1632	call histdef(nid_ins, "sens_"//clnsurf(nsrf),
1633	$ "Sensible heat flux "//clnsurf(nsrf), "W/m2",
1634	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1635	$ "inst(X)", zsto,zout)
1636	c
1637	call histdef(nid_ins, "tsol_"//clnsurf(nsrf),
1638	$ "Surface Temperature"//clnsurf(nsrf), "W/m2",
1639	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1640	$ "inst(X)", zsto,zout)
1641	c
1642	call histdef(nid_ins, "lat_"//clnsurf(nsrf),
1643	$ "Latent heat flux "//clnsurf(nsrf), "W/m2",
1644	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1645	$ "inst(X)", zsto,zout)
1646	C
1647	call histdef(nid_ins, "taux_"//clnsurf(nsrf),
1648	$ "Zonal wind stress"//clnsurf(nsrf),"Pa",
1649	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1650	$ "inst(X)", zsto,zout)
1651
1652	call histdef(nid_ins, "tauy_"//clnsurf(nsrf),
1653	$ "Meridional xind stress "//clnsurf(nsrf), "Pa",
1654	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1655	$ "inst(X)", zsto,zout)
1656	c
1657	call histdef(nid_ins, "albe_"//clnsurf(nsrf),
1658	$ "Albedo "//clnsurf(nsrf), "-",
1659	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1660	$ "inst(X)", zsto,zout)
1661	c
1662	call histdef(nid_ins, "rugs_"//clnsurf(nsrf),
1663	$ "rugosite "//clnsurf(nsrf), "-",
1664	$ iim,jjmp1,nhori, 1,1,1, -99, 32,
1665	$ "inst(X)", zsto,zout)
1666	C§§§
1667	END DO
1668	CALL histdef(nid_ins, "rugs", "rugosity", "-",
1669	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1670	. "inst(X)", zsto,zout)
1671
1672	c
1673	CALL histdef(nid_ins, "albs", "Surface albedo", "-",
1674	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1675	. "inst(X)", zsto,zout)
1676	CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-",
1677	. iim,jjmp1,nhori, 1,1,1, -99, 32,
1678	. "inst(X)", zsto,zout)
1679	c
1680	c
1681	c Champs 3D:
1682	c
1683	CALL histdef(nid_ins, "temp", "Temperature", "K",
1684	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1685	. "inst(X)", zsto,zout)
1686	c
1687	CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
1688	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1689	. "inst(X)", zsto,zout)
1690	c
1691	CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
1692	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1693	. "inst(X)", zsto,zout)
1694	c
1695	CALL histdef(nid_ins, "geop", "Geopotential height", "m",
1696	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1697	. "inst(X)", zsto,zout)
1698	c
1699	CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
1700	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1701	. "inst(X)", zsto,zout)
1702	c
1703	CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s",
1704	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1705	. "inst(X)", zsto,zout)
1706	c
1707	CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
1708	. iim,jjmp1,nhori, klev,1,klev,nvert, 32,
1709	. "inst(X)", zsto,zout)
1710	c
1711
1712	CALL histend(nid_ins)
1713	c
1714	ndex2d = 0
1715	ndex3d = 0
1716	c
1717	ENDIF
1718
1719	c$$$PB Positionner date0 pour initialisation de ORCHIDEE
1720	date0 = zjulian
1721	C date0 = day_ini
1722	WRITE(,) 'physiq date0 : ',date0
1723	c
1724	c
1725	c
1726	c Prescrire l'ozone dans l'atmosphere
1727	c
1728	c
1729	cc DO i = 1, klon
1730	cc DO k = 1, klev
1731	cc CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
1732	cc ENDDO
1733	cc ENDDO
1734	c
1735	c
1736	ENDIF
1737	c
1738	c ************** Fin de IF ( debut ) *************
1739	c
1740	c
1741	c Mettre a zero des variables de sortie (pour securite)
1742	c
1743	DO i = 1, klon
1744	d_ps(i) = 0.0
1745	ENDDO
1746	DO k = 1, klev
1747	DO i = 1, klon
1748	d_t(i,k) = 0.0
1749	d_u(i,k) = 0.0
1750	d_v(i,k) = 0.0
1751	ENDDO
1752	ENDDO
1753	DO iq = 1, nqmax
1754	DO k = 1, klev
1755	DO i = 1, klon
1756	d_qx(i,k,iq) = 0.0
1757	ENDDO
1758	ENDDO
1759	ENDDO
1760	c
1761	c Ne pas affecter les valeurs entrees de u, v, h, et q
1762	c
1763	DO k = 1, klev
1764	DO i = 1, klon
1765	t_seri(i,k) = t(i,k)
1766	u_seri(i,k) = u(i,k)
1767	v_seri(i,k) = v(i,k)
1768	q_seri(i,k) = qx(i,k,ivap)
1769	ql_seri(i,k) = qx(i,k,iliq)
1770	qs_seri(i,k) = 0.
1771	ENDDO
1772	ENDDO
1773	IF (nqmax.GE.3) THEN
1774	DO iq = 3, nqmax
1775	DO k = 1, klev
1776	DO i = 1, klon
1777	tr_seri(i,k,iq-2) = qx(i,k,iq)
1778	ENDDO
1779	ENDDO
1780	ENDDO
1781	ELSE
1782	DO k = 1, klev
1783	DO i = 1, klon
1784	tr_seri(i,k,1) = 0.0
1785	ENDDO
1786	ENDDO
1787	ENDIF
1788	C
1789	IF (if_ebil.ge.1) THEN
1790	DO i = 1, klon
1791	ztsol(i) = 0.
1792	ENDDO
1793	DO nsrf = 1, nbsrf
1794	DO i = 1, klon
1795	ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
1796	ENDDO
1797	ENDDO
1798	ztit='after dynamic'
1799	CALL diagetpq(paire,ztit,ip_ebil,1,1,dtime
1800	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
1801	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
1802	C Comme les tendances de la physique sont ajoute dans la dynamique,
1803	C on devrait avoir que la variation d'entalpie par la dynamique
1804	C est egale a la variation de la physique au pas de temps precedent.
1805	C Donc la somme de ces 2 variations devrait etre nulle.
1806	call diagphy(paire,ztit,ip_ebil
1807	e , zero_v, zero_v, zero_v, zero_v, zero_v
1808	e , zero_v, zero_v, zero_v, ztsol
1809	e , d_h_vcol+d_h_vcol_phy, d_qt, 0.
1810	s , fs_bound, fq_bound )
1811	END IF
1812
1813	c Diagnostiquer la tendance dynamique
1814	c
1815	IF (ancien_ok) THEN
1816	DO k = 1, klev
1817	DO i = 1, klon
1818	d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
1819	d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
1820	ENDDO
1821	ENDDO
1822	ELSE
1823	DO k = 1, klev
1824	DO i = 1, klon
1825	d_t_dyn(i,k) = 0.0
1826	d_q_dyn(i,k) = 0.0
1827	ENDDO
1828	ENDDO
1829	ancien_ok = .TRUE.
1830	ENDIF
1831	c
1832	c Ajouter le geopotentiel du sol:
1833	c
1834	DO k = 1, klev
1835	DO i = 1, klon
1836	zphi(i,k) = pphi(i,k) + pphis(i)
1837	ENDDO
1838	ENDDO
1839	c
1840	c Verifier les temperatures
1841	c
1842	CALL hgardfou(t_seri,ftsol,'debutphy')
1843	c
1844	c Incrementer le compteur de la physique
1845	c
1846	itap = itap + 1
1847	julien = MOD(NINT(xjour),360)
1848	c
1849	c Mettre en action les conditions aux limites (albedo, sst, etc.).
1850	c Prescrire l'ozone et calculer l'albedo sur l'ocean.
1851	c
1852	IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN
1853	PRINT *,' PHYS cond julien ',julien
1854	CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
1855	ENDIF
1856	c
1857	c Re-evaporer l'eau liquide nuageuse
1858	c
1859	DO k = 1, klev ! re-evaporation de l'eau liquide nuageuse
1860	DO i = 1, klon
1861	zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
1862	c zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
1863	zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
1864	zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
1865	zb = MAX(0.0,ql_seri(i,k))
1866	za = - MAX(0.0,ql_seri(i,k))
1867	. * (zlvdcp(1.-zdelta)+zlsdcpzdelta)
1868	t_seri(i,k) = t_seri(i,k) + za
1869	q_seri(i,k) = q_seri(i,k) + zb
1870	ql_seri(i,k) = 0.0
1871	d_t_eva(i,k) = za
1872	d_q_eva(i,k) = zb
1873	ENDDO
1874	ENDDO
1875	c
1876	IF (if_ebil.ge.2) THEN
1877	ztit='after reevap'
1878	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
1879	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
1880	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
1881	call diagphy(paire,ztit,ip_ebil
1882	e , zero_v, zero_v, zero_v, zero_v, zero_v
1883	e , zero_v, zero_v, zero_v, ztsol
1884	e , d_h_vcol, d_qt, d_ec
1885	s , fs_bound, fq_bound )
1886	C
1887	END IF
1888	C
1889	c
1890	c Appeler la diffusion verticale (programme de couche limite)
1891	c
1892	DO i = 1, klon
1893	c if (.not. ok_veget) then
1894	c frugs(i,is_ter) = SQRT(frugs(i,is_ter)2+rugoro(i)2)
1895	c endif
1896	c frugs(i,is_lic) = rugoro(i)
1897	c frugs(i,is_oce) = rugmer(i)
1898	c frugs(i,is_sic) = 0.001
1899	zxrugs(i) = 0.0
1900	ENDDO
1901	DO nsrf = 1, nbsrf
1902	DO i = 1, klon
1903	c$$$ frugs(i,nsrf) = MAX(frugs(i,nsrf),0.001
1904	frugs(i,nsrf) = MAX(frugs(i,nsrf),0.000015)
1905	ENDDO
1906	ENDDO
1907	DO nsrf = 1, nbsrf
1908	DO i = 1, klon
1909	zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf)
1910	ENDDO
1911	ENDDO
1912	c
1913	C calculs necessaires au calcul de l'albedo dans l'interface
1914	c
1915	CALL orbite(FLOAT(julien),zlongi,dist)
1916	IF (cycle_diurne) THEN
1917	zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
1918	CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
1919	ELSE
1920	rmu0 = -999.999
1921	ENDIF
1922
1923	fder = dlw
1924
1925	CALL clmain(dtime,itap,date0,pctsrf,
1926	e t_seri,q_seri,u_seri,v_seri,
1927	e julien, rmu0,
1928	e ok_veget, ocean, npas, nexca, ftsol,
1929	$ soil_model,ftsoil,
1930	$ paprs,pplay,radsol, fsnow,fqsol,fevap,falbe,falblw,
1931	$ fluxlat,
1932	e rain_fall, snow_fall, solsw, sollw, sollwdown, fder,
1933	e rlon, rlat, cufi, cvfi, frugs,
1934	e debut, lafin, agesno,rugoro ,
1935	s d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts,
1936	s fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,
1937	s dsens, devap,
1938	s ycoefh,yu1,yv1)
1939
1940	c
1941	C§§§ PB
1942	C§§§ Incrementation des flux
1943	C§§
1944	zxfluxt=0.
1945	zxfluxq=0.
1946	zxfluxu=0.
1947	zxfluxv=0.
1948	DO nsrf = 1, nbsrf
1949	DO k = 1, klev
1950	DO i = 1, klon
1951	zxfluxt(i,k) = zxfluxt(i,k) +
1952	$ fluxt(i,k,nsrf) * pctsrf( i, nsrf)
1953	zxfluxq(i,k) = zxfluxq(i,k) +
1954	$ fluxq(i,k,nsrf) * pctsrf( i, nsrf)
1955	zxfluxu(i,k) = zxfluxu(i,k) +
1956	$ fluxu(i,k,nsrf) * pctsrf( i, nsrf)
1957	zxfluxv(i,k) = zxfluxv(i,k) +
1958	$ fluxv(i,k,nsrf) * pctsrf( i, nsrf)
1959	END DO
1960	END DO
1961	END DO
1962	DO i = 1, klon
1963	sens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol
1964	c evap(i) = - fluxq(i,1) ! flux d'evaporation au sol
1965	evap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol
1966	fder(i) = dlw(i) + dsens(i) + devap(i)
1967	ENDDO
1968
1969
1970	DO k = 1, klev
1971	DO i = 1, klon
1972	t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k)
1973	q_seri(i,k) = q_seri(i,k) + d_q_vdf(i,k)
1974	u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k)
1975	v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k)
1976	ENDDO
1977	ENDDO
1978	c
1979	IF (if_ebil.ge.2) THEN
1980	ztit='after clmain'
1981	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
1982	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
1983	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
1984	call diagphy(paire,ztit,ip_ebil
1985	e , zero_v, zero_v, zero_v, zero_v, sens
1986	e , evap , zero_v, zero_v, ztsol
1987	e , d_h_vcol, d_qt, d_ec
1988	s , fs_bound, fq_bound )
1989	END IF
1990	C
1991	c
1992	c Incrementer la temperature du sol
1993	c
1994	DO i = 1, klon
1995	zxtsol(i) = 0.0
1996	zxfluxlat(i) = 0.0
1997	IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) +
1998	$ pctsrf(i, is_oce) + pctsrf(i, is_sic) - 1.) .GT. EPSFRA)
1999	$ THEN
2000	WRITE(,) 'physiq : pb sous surface au point ', i,
2001	$ pctsrf(i, 1 : nbsrf)
2002	ENDIF
2003	ENDDO
2004	DO nsrf = 1, nbsrf
2005	DO i = 1, klon
2006	c$$$ IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN
2007	ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf)
2008	zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
2009	zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf)*pctsrf(i,nsrf)
2010	c$$$ ENDIF
2011	ENDDO
2012	ENDDO
2013
2014	c
2015	c Si une sous-fraction n'existe pas, elle prend la temp. moyenne
2016	c
2017	DO nsrf = 1, nbsrf
2018	DO i = 1, klon
2019	IF (pctsrf(i,nsrf) .LT. epsfra) ftsol(i,nsrf) = zxtsol(i)
2020	ENDDO
2021	ENDDO
2022
2023	c
2024	c Calculer la derive du flux infrarouge
2025	c
2026	c$$$ DO nsrf = 1, nbsrf
2027	DO i = 1, klon
2028	c$$$ IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN
2029	dlw(i) = - 4.0RSIGMAzxtsol(i)**3
2030	c$$$ . *(ftsol(i,nsrf)-zxtsol(i))
2031	c$$$ . *pctsrf(i,nsrf)
2032	c$$$ ENDIF
2033	c$$$ ENDDO
2034	ENDDO
2035	c
2036	c Appeler la convection (au choix)
2037	c
2038	DO k = 1, klev
2039	DO i = 1, klon
2040	conv_q(i,k) = d_q_dyn(i,k)
2041	. + d_q_vdf(i,k)/dtime
2042	conv_t(i,k) = d_t_dyn(i,k)
2043	. + d_t_vdf(i,k)/dtime
2044	ENDDO
2045	ENDDO
2046	IF (check) THEN
2047	za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
2048	PRINT*, "avantcon=", za
2049	ENDIF
2050	zx_ajustq = .FALSE.
2051	IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
2052	IF (zx_ajustq) THEN
2053	DO i = 1, klon
2054	z_avant(i) = 0.0
2055	ENDDO
2056	DO k = 1, klev
2057	DO i = 1, klon
2058	z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))
2059	. *(paprs(i,k)-paprs(i,k+1))/RG
2060	ENDDO
2061	ENDDO
2062	ENDIF
2063	IF (iflag_con.EQ.1) THEN
2064	stop'reactiver le call conlmd dans physiq.F'
2065	c CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
2066	c . d_t_con, d_q_con,
2067	c . rain_con, snow_con, ibas_con, itop_con)
2068	ELSE IF (iflag_con.EQ.2) THEN
2069	CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
2070	e conv_t, conv_q, zxfluxq(1,1), omega,
2071	s d_t_con, d_q_con, rain_con, snow_con,
2072	s pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
2073	s kcbot, kctop, kdtop, pmflxr, pmflxs)
2074	WHERE (rain_con < 0.) rain_con = 0.
2075	WHERE (snow_con < 0.) snow_con = 0.
2076	DO i = 1, klon
2077	ibas_con(i) = klev+1 - kcbot(i)
2078	itop_con(i) = klev+1 - kctop(i)
2079	ENDDO
2080	ELSE IF (iflag_con.GE.3) THEN
2081	c nb of tracers for the KE convection:
2082	if (nqmax .GE. 4) then
2083	ntra = nbtr
2084	else
2085	ntra = 1
2086	endif
2087	if (iflag_con.eq.4) then ! vectorise
2088	CALL conemav (dtime,paprs,pplay,t_seri,q_seri,
2089	. u_seri,v_seri,tr_seri,nbtr,
2090	. ema_work1,ema_work2,
2091	. d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
2092	. rain_con, snow_con, ibas_con, itop_con,
2093	. upwd,dnwd,dnwd0,
2094	c . Ma,cape,tvp,(/(nint(rflag(i)),i=1,size(rflag))/),
2095	. Ma,cape,tvp,iflagctrl,
2096	. pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
2097
2098	else
2099
2100	c print*,'Avant conema OUI'
2101	CALL conema3 (dtime,
2102	. paprs,pplay,t_seri,q_seri,
2103	. u_seri,v_seri,tr_seri,nbtr,
2104	. ema_work1,ema_work2,
2105	. d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
2106	. rain_con, snow_con, ibas_con, itop_con,
2107	. upwd,dnwd,dnwd0,bas,top,
2108	. Ma,cape,tvp,rflag,
2109	. pbase
2110	. ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr
2111	. ,clwcon0)
2112	c print*,'Apres conema3 '
2113
2114	c Calculer l'humidite relative pour diagnostique
2115	c
2116	DO k = 1, klev
2117	DO i = 1, klon
2118	zx_t = t_seri(i,k)
2119	IF (thermcep) THEN
2120	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
2121	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
2122	zx_qs = MIN(0.5,zx_qs)
2123	zcor = 1./(1.-retv*zx_qs)
2124	zx_qs = zx_qs*zcor
2125	ELSE
2126	IF (zx_t.LT.t_coup) THEN
2127	zx_qs = qsats(zx_t)/pplay(i,k)
2128	ELSE
2129	zx_qs = qsatl(zx_t)/pplay(i,k)
2130	ENDIF
2131	ENDIF
2132	zqsat(i,k)=zx_qs
2133	ENDDO
2134	ENDDO
2135
2136	c calcul des propriétés des nuages convectifs
2137	clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
2138	call clouds_gno
2139	s (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
2140
2141	endif
2142	DO i = 1, klon
2143	ema_pcb(i) = pbase(i)
2144	ENDDO
2145	DO i = 1, klon
2146	ema_pct(i) = paprs(i,itop_con(i))
2147	ENDDO
2148	DO i = 1, klon
2149	ema_cbmf(i) = ema_workcbmf(i)
2150	ENDDO
2151	ELSE
2152	PRINT*, "iflag_con non-prevu", iflag_con
2153	CALL abort
2154	ENDIF
2155
2156	c CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
2157	c . d_u_con, d_v_con)
2158	DO k = 1, klev
2159	DO i = 1, klon
2160	t_seri(i,k) = t_seri(i,k) + d_t_con(i,k)
2161	q_seri(i,k) = q_seri(i,k) + d_q_con(i,k)
2162	u_seri(i,k) = u_seri(i,k) + d_u_con(i,k)
2163	v_seri(i,k) = v_seri(i,k) + d_v_con(i,k)
2164	ENDDO
2165	ENDDO
2166	c
2167	IF (if_ebil.ge.2) THEN
2168	ztit='after convect'
2169	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2170	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2171	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2172	call diagphy(paire,ztit,ip_ebil
2173	e , zero_v, zero_v, zero_v, zero_v, zero_v
2174	e , zero_v, rain_con, snow_con, ztsol
2175	e , d_h_vcol, d_qt, d_ec
2176	s , fs_bound, fq_bound )
2177	END IF
2178	C
2179	IF (check) THEN
2180	za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
2181	PRINT*, "aprescon=", za
2182	zx_t = 0.0
2183	za = 0.0
2184	DO i = 1, klon
2185	za = za + paire(i)/FLOAT(klon)
2186	zx_t = zx_t + (rain_con(i)+snow_con(i))*paire(i)/FLOAT(klon)
2187	ENDDO
2188	zx_t = zx_t/za*dtime
2189	PRINT*, "Precip=", zx_t
2190	ENDIF
2191	IF (zx_ajustq) THEN
2192	DO i = 1, klon
2193	z_apres(i) = 0.0
2194	ENDDO
2195	DO k = 1, klev
2196	DO i = 1, klon
2197	z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))
2198	. *(paprs(i,k)-paprs(i,k+1))/RG
2199	ENDDO
2200	ENDDO
2201	DO i = 1, klon
2202	z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)
2203	. /z_apres(i)
2204	ENDDO
2205	DO k = 1, klev
2206	DO i = 1, klon
2207	IF (z_factor(i).GT.(1.0+1.0E-08) .OR.
2208	. z_factor(i).LT.(1.0-1.0E-08)) THEN
2209	q_seri(i,k) = q_seri(i,k) * z_factor(i)
2210	ENDIF
2211	ENDDO
2212	ENDDO
2213	ENDIF
2214	zx_ajustq=.FALSE.
2215	c
2216	IF (nqmax.GT.2) THEN !--melange convectif de traceurs
2217	c
2218	IF (iflag_con .NE. 2 .AND. debut) THEN
2219	PRINT*, 'Pour l instant, seul conflx fonctionne ',
2220	$ 'avec traceurs', iflag_con
2221	PRINT*,' Mettre iflag_con',
2222	$ ' = 2 dans run.def et repasser'
2223	c CALL abort
2224	ENDIF
2225	c
2226	ENDIF !--nqmax.GT.2
2227	c
2228	c Appeler l'ajustement sec
2229	c
2230	CALL ajsec(paprs, pplay, t_seri, q_seri, d_t_ajs, d_q_ajs)
2231	DO k = 1, klev
2232	DO i = 1, klon
2233	t_seri(i,k) = t_seri(i,k) + d_t_ajs(i,k)
2234	q_seri(i,k) = q_seri(i,k) + d_q_ajs(i,k)
2235	ENDDO
2236	ENDDO
2237	c
2238	IF (if_ebil.ge.2) THEN
2239	ztit='after dry_adjust'
2240	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2241	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2242	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2243	END IF
2244
2245
2246	c-------------------------------------------------------------------------
2247	c Caclul des ratqs
2248	c-------------------------------------------------------------------------
2249
2250	c print*,'calcul des ratqs'
2251	c ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
2252	c ----------------
2253	c on ecrase le tableau ratqsc calcule par clouds_gno
2254	if (iflag_cldcon.eq.1) then
2255	do k=1,klev
2256	do i=1,klon
2257	if(ptconv(i,k)) then
2258	ratqsc(i,k)=ratqsbas
2259	s +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
2260	else
2261	ratqsc(i,k)=0.
2262	endif
2263	enddo
2264	enddo
2265	endif
2266
2267	c ratqs stables
2268	c -------------
2269	do k=1,klev
2270	ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas)*
2271	s min((paprs(:,1)-pplay(:,k))/(paprs(:,1)-30000.),1.)
2272	enddo
2273
2274
2275	c ratqs final
2276	c -----------
2277	if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2) then
2278	c les ratqs sont une conbinaison de ratqss et ratqsc
2279	c ratqs final
2280	c 1e4 (en gros 3 heures), en dur pour le moment, est le temps de
2281	c relaxation des ratqs
2282	c facttemps=exp(-pdtphys/1.e4)
2283	facteur=exp(-pdtphys*facttemps)
2284	ratqs(:,:)=max(ratqs(:,:)*facteur,ratqss(:,:))
2285	ratqs(:,:)=max(ratqs(:,:),ratqsc(:,:))
2286	c print*,'calcul des ratqs fini'
2287	else
2288	c on ne prend que le ratqs stable pour fisrtilp
2289	ratqs(:,:)=ratqss(:,:)
2290	endif
2291
2292
2293	c
2294	c Appeler le processus de condensation a grande echelle
2295	c et le processus de precipitation
2296	c-------------------------------------------------------------------------
2297	CALL fisrtilp(dtime,paprs,pplay,
2298	. t_seri, q_seri,ptconv,ratqs,
2299	. d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,
2300	. rain_lsc, snow_lsc,
2301	. pfrac_impa, pfrac_nucl, pfrac_1nucl,
2302	. frac_impa, frac_nucl,
2303	. prfl, psfl, rhcl)
2304
2305	WHERE (rain_lsc < 0) rain_lsc = 0.
2306	WHERE (snow_lsc < 0) snow_lsc = 0.
2307	DO k = 1, klev
2308	DO i = 1, klon
2309	t_seri(i,k) = t_seri(i,k) + d_t_lsc(i,k)
2310	q_seri(i,k) = q_seri(i,k) + d_q_lsc(i,k)
2311	ql_seri(i,k) = ql_seri(i,k) + d_ql_lsc(i,k)
2312	cldfra(i,k) = rneb(i,k)
2313	IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
2314	ENDDO
2315	ENDDO
2316	IF (check) THEN
2317	za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
2318	PRINT*, "apresilp=", za
2319	zx_t = 0.0
2320	za = 0.0
2321	DO i = 1, klon
2322	za = za + paire(i)/FLOAT(klon)
2323	zx_t = zx_t + (rain_lsc(i)+snow_lsc(i))*paire(i)/FLOAT(klon)
2324	ENDDO
2325	zx_t = zx_t/za*dtime
2326	PRINT*, "Precip=", zx_t
2327	ENDIF
2328	c
2329	IF (if_ebil.ge.2) THEN
2330	ztit='after fisrt'
2331	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2332	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2333	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2334	call diagphy(paire,ztit,ip_ebil
2335	e , zero_v, zero_v, zero_v, zero_v, zero_v
2336	e , zero_v, rain_lsc, snow_lsc, ztsol
2337	e , d_h_vcol, d_qt, d_ec
2338	s , fs_bound, fq_bound )
2339	END IF
2340	c
2341	c-------------------------------------------------------------------
2342	c PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
2343	c-------------------------------------------------------------------
2344
2345	c 1. NUAGES CONVECTIFS
2346	c
2347	IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
2348
2349	c Nuages diagnostiques pour Tiedtke
2350	CALL diagcld1(paprs,pplay,
2351	. rain_con,snow_con,ibas_con,itop_con,
2352	. diafra,dialiq)
2353	DO k = 1, klev
2354	DO i = 1, klon
2355	IF (diafra(i,k).GT.cldfra(i,k)) THEN
2356	cldliq(i,k) = dialiq(i,k)
2357	cldfra(i,k) = diafra(i,k)
2358	ENDIF
2359	ENDDO
2360	ENDDO
2361
2362	ELSE IF (iflag_cldcon.eq.3) THEN
2363	c On prend pour les nuages convectifs le max du calcul de la
2364	c convection et du calcul du pas de temps précédent diminué d'un facteur
2365	c facttemps
2366	c facttemps=pdtphys/1.e4
2367	facteur = pdtphys *facttemps
2368	do k=1,klev
2369	do i=1,klon
2370	rnebcon(i,k)=rnebcon(i,k)*facteur
2371	if (rnebcon0(i,k)clwcon0(i,k).gt.rnebcon(i,k)clwcon(i,k))
2372	s then
2373	rnebcon(i,k)=rnebcon0(i,k)
2374	clwcon(i,k)=clwcon0(i,k)
2375	endif
2376	enddo
2377	enddo
2378
2379	c On prend la somme des fractions nuageuses et des contenus en eau
2380	cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
2381	cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
2382
2383
2384	ENDIF
2385	c
2386	c 2. NUAGES STARTIFORMES
2387	c
2388	IF (ok_stratus) THEN
2389	CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
2390	DO k = 1, klev
2391	DO i = 1, klon
2392	IF (diafra(i,k).GT.cldfra(i,k)) THEN
2393	cldliq(i,k) = dialiq(i,k)
2394	cldfra(i,k) = diafra(i,k)
2395	ENDIF
2396	ENDDO
2397	ENDDO
2398	ENDIF
2399	c
2400	c Precipitation totale
2401	c
2402	DO i = 1, klon
2403	rain_fall(i) = rain_con(i) + rain_lsc(i)
2404	snow_fall(i) = snow_con(i) + snow_lsc(i)
2405	ENDDO
2406	c
2407	IF (if_ebil.ge.2) THEN
2408	ztit="after diagcld"
2409	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2410	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2411	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2412	END IF
2413	c
2414	c Calculer l'humidite relative pour diagnostique
2415	c
2416	DO k = 1, klev
2417	DO i = 1, klon
2418	zx_t = t_seri(i,k)
2419	IF (thermcep) THEN
2420	zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
2421	zx_qs = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
2422	zx_qs = MIN(0.5,zx_qs)
2423	zcor = 1./(1.-retv*zx_qs)
2424	zx_qs = zx_qs*zcor
2425	ELSE
2426	IF (zx_t.LT.t_coup) THEN
2427	zx_qs = qsats(zx_t)/pplay(i,k)
2428	ELSE
2429	zx_qs = qsatl(zx_t)/pplay(i,k)
2430	ENDIF
2431	ENDIF
2432	zx_rh(i,k) = q_seri(i,k)/zx_qs
2433	zqsat(i,k)=zx_qs
2434	ENDDO
2435	ENDDO
2436	c
2437	c Calculer les parametres optiques des nuages et quelques
2438	c parametres pour diagnostiques:
2439	c
2440	if (ok_newmicro) then
2441	CALL newmicro (paprs, pplay,ok_newmicro,
2442	. t_seri, cldliq, cldfra, cldtau, cldemi,
2443	. cldh, cldl, cldm, cldt, cldq)
2444	else
2445	CALL nuage (paprs, pplay,
2446	. t_seri, cldliq, cldfra, cldtau, cldemi,
2447	. cldh, cldl, cldm, cldt, cldq)
2448	endif
2449	c
2450	c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
2451	c
2452	IF (MOD(itaprad,radpas).EQ.0) THEN
2453	DO i = 1, klon
2454	albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce)
2455	. + falbe(i,is_lic) * pctsrf(i,is_lic)
2456	. + falbe(i,is_ter) * pctsrf(i,is_ter)
2457	. + falbe(i,is_sic) * pctsrf(i,is_sic)
2458	albsollw(i) = falblw(i,is_oce) * pctsrf(i,is_oce)
2459	. + falblw(i,is_lic) * pctsrf(i,is_lic)
2460	. + falblw(i,is_ter) * pctsrf(i,is_ter)
2461	. + falblw(i,is_sic) * pctsrf(i,is_sic)
2462	ENDDO
2463	! if (debut) then
2464	! albsol1 = albsol
2465	! albsollw1 = albsollw
2466	! endif
2467	! albsol = albsol1
2468	! albsollw = albsollw1
2469	CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
2470	e (dist, rmu0, fract, co2_ppm, solaire,
2471	e paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
2472	e wo,
2473	e cldfra, cldemi, cldtau,
2474	s heat,heat0,cool,cool0,radsol,albpla,
2475	s topsw,toplw,solsw,sollw,
2476	s sollwdown,
2477	s topsw0,toplw0,solsw0,sollw0)
2478	itaprad = 0
2479	ENDIF
2480	itaprad = itaprad + 1
2481	c
2482	c Ajouter la tendance des rayonnements (tous les pas)
2483	c
2484	DO k = 1, klev
2485	DO i = 1, klon
2486	t_seri(i,k) = t_seri(i,k)
2487	. + (heat(i,k)-cool(i,k)) * dtime/86400.
2488	ENDDO
2489	ENDDO
2490	c
2491	IF (if_ebil.ge.2) THEN
2492	ztit='after rad'
2493	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2494	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2495	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2496	call diagphy(paire,ztit,ip_ebil
2497	e , topsw, toplw, solsw, sollw, zero_v
2498	e , zero_v, zero_v, zero_v, ztsol
2499	e , d_h_vcol, d_qt, d_ec
2500	s , fs_bound, fq_bound )
2501	END IF
2502	c
2503	c
2504	c Calculer l'hydrologie de la surface
2505	c
2506	c CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
2507	c . agesno, ftsol,fqsol,fsnow, ruis)
2508	c
2509	DO i = 1, klon
2510	zxqsol(i) = 0.0
2511	zxsnow(i) = 0.0
2512	ENDDO
2513	DO nsrf = 1, nbsrf
2514	DO i = 1, klon
2515	zxqsol(i) = zxqsol(i) + fqsol(i,nsrf)*pctsrf(i,nsrf)
2516	zxsnow(i) = zxsnow(i) + fsnow(i,nsrf)*pctsrf(i,nsrf)
2517	ENDDO
2518	ENDDO
2519	c
2520	c Si une sous-fraction n'existe pas, elle prend la valeur moyenne
2521	c
2522	c$$$ DO nsrf = 1, nbsrf
2523	c$$$ DO i = 1, klon
2524	c$$$ IF (pctsrf(i,nsrf).LT.epsfra) THEN
2525	c$$$ fqsol(i,nsrf) = zxqsol(i)
2526	c$$$ fsnow(i,nsrf) = zxsnow(i)
2527	c$$$ ENDIF
2528	c$$$ ENDDO
2529	c$$$ ENDDO
2530	c
2531	c Calculer le bilan du sol et la derive de temperature (couplage)
2532	c
2533	DO i = 1, klon
2534	c bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
2535	c a la demande de JLD
2536	bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
2537	ENDDO
2538	c
2539	cmoddeblott(jan95)
2540	c Appeler le programme de parametrisation de l'orographie
2541	c a l'echelle sous-maille:
2542	c
2543	IF (ok_orodr) THEN
2544	c
2545	c selection des points pour lesquels le shema est actif:
2546	igwd=0
2547	DO i=1,klon
2548	itest(i)=0
2549	c IF ((zstd(i).gt.10.0)) THEN
2550	IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
2551	itest(i)=1
2552	igwd=igwd+1
2553	idx(igwd)=i
2554	ENDIF
2555	ENDDO
2556	c igwdim=MAX(1,igwd)
2557	c
2558	CALL drag_noro(klon,klev,dtime,paprs,pplay,
2559	e zmea,zstd, zsig, zgam, zthe,zpic,zval,
2560	e igwd,idx,itest,
2561	e t_seri, u_seri, v_seri,
2562	s zulow, zvlow, zustr, zvstr,
2563	s d_t_oro, d_u_oro, d_v_oro)
2564	c
2565	c ajout des tendances
2566	DO k = 1, klev
2567	DO i = 1, klon
2568	t_seri(i,k) = t_seri(i,k) + d_t_oro(i,k)
2569	u_seri(i,k) = u_seri(i,k) + d_u_oro(i,k)
2570	v_seri(i,k) = v_seri(i,k) + d_v_oro(i,k)
2571	ENDDO
2572	ENDDO
2573	c
2574	ENDIF ! fin de test sur ok_orodr
2575	c
2576	IF (ok_orolf) THEN
2577	c
2578	c selection des points pour lesquels le shema est actif:
2579	igwd=0
2580	DO i=1,klon
2581	itest(i)=0
2582	IF ((zpic(i)-zmea(i)).GT.100.) THEN
2583	itest(i)=1
2584	igwd=igwd+1
2585	idx(igwd)=i
2586	ENDIF
2587	ENDDO
2588	c igwdim=MAX(1,igwd)
2589	c
2590	CALL lift_noro(klon,klev,dtime,paprs,pplay,
2591	e rlat,zmea,zstd,zpic,
2592	e itest,
2593	e t_seri, u_seri, v_seri,
2594	s zulow, zvlow, zustr, zvstr,
2595	s d_t_lif, d_u_lif, d_v_lif)
2596	c
2597	c ajout des tendances
2598	DO k = 1, klev
2599	DO i = 1, klon
2600	t_seri(i,k) = t_seri(i,k) + d_t_lif(i,k)
2601	u_seri(i,k) = u_seri(i,k) + d_u_lif(i,k)
2602	v_seri(i,k) = v_seri(i,k) + d_v_lif(i,k)
2603	ENDDO
2604	ENDDO
2605	c
2606	ENDIF ! fin de test sur ok_orolf
2607	c
2608	IF (if_ebil.ge.2) THEN
2609	ztit='after orography'
2610	CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
2611	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2612	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2613	END IF
2614	c
2615	c
2616	cAA
2617	cAA Installation de l'interface online-offline pour traceurs
2618	cAA
2619	c====================================================================
2620	c Calcul des tendances traceurs
2621	c====================================================================
2622	C Pascale : il faut quand meme apeller phytrac car il gere les sorties
2623	cKE43 des traceurs => il faut donc mettre des flags a .false.
2624	IF (iflag_con.GE.3) THEN
2625	c on ajoute les tendances calculees par KE43
2626	c$$$ OM on onhibe la convection sur les traceurs
2627	DO iq=1, nqmax-2 ! Sandrine a -3 ???
2628	c$$$ OM on inhibe la convection sur les traceur
2629	c$$$ DO k = 1, nlev
2630	c$$$ DO i = 1, klon
2631	c$$$ tr_seri(i,k,iq) = tr_seri(i,k,iq) + d_tr(i,k,iq)
2632	c$$$ ENDDO
2633	c$$$ ENDDO
2634	WRITE(iqn,'(i2.2)') iq
2635	CALL minmaxqfi(tr_seri(1,1,iq),0.,1.e33,'couche lim iq='//iqn)
2636	ENDDO
2637	CMAF modif pour garder info du nombre de traceurs auxquels
2638	C la physique s'applique
2639	ELSE
2640	CMAF modif pour garder info du nombre de traceurs auxquels
2641	C la physique s'applique
2642	C
2643	call phytrac (rnpb,
2644	I debut,lafin,
2645	I nqmax-2,
2646	I nlon,nlev,dtime,
2647	I t,paprs,pplay,
2648	I pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
2649	I ycoefh,yu1,yv1,ftsol,pctsrf,rlat,
2650	I frac_impa, frac_nucl,
2651	I rlon,presnivs,paire,pphis,
2652	O tr_seri)
2653	ENDIF
2654
2655	IF (offline) THEN
2656
2657	call phystokenc (
2658	I nlon,nlev,pdtphys,rlon,rlat,
2659	I t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
2660	I ycoefh,yu1,yv1,ftsol,pctsrf,
2661	I frac_impa, frac_nucl,
2662	I pphis,paire,dtime,itap)
2663
2664
2665	ENDIF
2666
2667	c
2668	c Calculer le transport de l'eau et de l'energie (diagnostique)
2669	c
2670	CALL transp (paprs,zxtsol,
2671	e t_seri, q_seri, u_seri, v_seri, zphi,
2672	s ve, vq, ue, uq)
2673	c
2674	c Accumuler les variables a stocker dans les fichiers histoire:
2675	c
2676	c
2677	c
2678	IF (if_ebil.ge.1) THEN
2679	ztit='after physic'
2680	CALL diagetpq(paire,ztit,ip_ebil,1,1,dtime
2681	e , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
2682	s , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
2683	C Comme les tendances de la physique sont ajoute dans la dynamique,
2684	C on devrait avoir que la variation d'entalpie par la dynamique
2685	C est egale a la variation de la physique au pas de temps precedent.
2686	C Donc la somme de ces 2 variations devrait etre nulle.
2687	call diagphy(paire,ztit,ip_ebil
2688	e , topsw, toplw, solsw, sollw, sens
2689	e , evap, rain_fall, snow_fall, ztsol
2690	e , d_h_vcol, d_qt, d_ec
2691	s , fs_bound, fq_bound )
2692	C
2693	d_h_vcol_phy=d_h_vcol
2694	C
2695	END IF
2696	C
2697	IF (ok_journe) THEN
2698	c
2699	ndex2d = 0
2700	ndex3d = 0
2701	c
2702	c Champs 2D:
2703	c
2704	zsto = dtime
2705	zout = dtime * FLOAT(ecrit_day)
2706	itau_w = itau_phy + itap
2707
2708	i = NINT(zout/zsto)
2709	CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
2710	CALL histwrite(nid_day,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2711	varname = 'phis'
2712	vartitle= 'Surface geop. height'
2713	varunits= '-'
2714	c call writephy(fid_day,prof2d_on,varname,pphis,vartitle,
2715	c . varunits)
2716	c
2717	i = NINT(zout/zsto)
2718	CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
2719	CALL histwrite(nid_day,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2720	varname = 'aire'
2721	vartitle= 'Grid area'
2722	varunits= '-'
2723	c call writephy(fid_day,prof2d_on,varname,paire,vartitle,
2724	c . varunits)
2725	C
2726	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
2727	CALL histwrite(nid_day,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2728	c call writephy(fid_day,prof2d_av,'tsol',zxtsol,
2729	c . 'Surface Temperature','K')
2730	c
2731	C
2732	zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter)
2733	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d)
2734	CALL histwrite(nid_day,"tter",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2735	c call writephy(fid_day,prof2d_av,'tter',ftsol(1 : klon, is_ter),
2736	c . 'Surface Temperature','K')
2737	C
2738	zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic)
2739	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2740	CALL histwrite(nid_day,"tlic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2741	c call writephy(fid_day,prof2d_av,'tlic',ftsol(1 : klon, is_lic),
2742	c . 'Surface Temperature','K')
2743	C
2744	zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce)
2745	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2746	CALL histwrite(nid_day,"toce",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2747	c call writephy(fid_day,prof2d_av,'toce',ftsol(1 : klon, is_oce),
2748	c . 'Surface Temperature','K')
2749	C
2750	zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic)
2751	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2752	CALL histwrite(nid_day,"tsic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2753	c call writephy(fid_day,prof2d_av,'tsic',ftsol(1 : klon, is_sic),
2754	c . 'Surface Temperature','K')
2755	C
2756	DO i = 1, klon
2757	zx_tmp_fi2d(i) = paprs(i,1)
2758	ENDDO
2759	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2760	CALL histwrite(nid_day,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2761	c Essai writephys
2762	varname = 'psol'
2763	vartitle= 'pression au sol'
2764	varunits= 'hPa'
2765	c call writephy(fid_day,prof2d_av,varname,zx_tmp_fi2d,vartitle,
2766	c . varunits)
2767	c
2768	DO i = 1, klon
2769	zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i))
2770	ENDDO
2771	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2772	CALL histwrite(nid_day,"rain",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2773	c call writephy(fid_day,prof2d_av,'rain',zx_tmp_fi2d,
2774	c . 'Precipitation','mm/day')
2775
2776
2777	c
2778	CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
2779	CALL histwrite(nid_day,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2780	c call writephy(fid_day,prof2d_av,'snow',snow_fall,
2781	c . 'Snow','mm/day')
2782	c
2783	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
2784	CALL histwrite(nid_day,"snow_cov",itau_w,zx_tmp_2d,iim*jjmp1,
2785	. ndex2d)
2786	c call writephy(fid_day,prof2d_av,'snow_cov',zxsnow,
2787	c . 'Snow cover','mm')
2788	c
2789	CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
2790	CALL histwrite(nid_day,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2791	c call writephy(fid_day,prof2d_av,'evap',evap,
2792	c . 'Evaporation','mm/day')
2793	c
2794	CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
2795	CALL histwrite(nid_day,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2796	c call writephy(fid_day,prof2d_av,'tops',topsw,
2797	c . 'Solar rad. at TOA','W/m2')
2798	c
2799	CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
2800	CALL histwrite(nid_day,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2801	c call writephy(fid_day,prof2d_av,'topl',toplw,
2802	c . 'IR rad. at TOA','W/m2')
2803	c
2804	CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
2805	CALL histwrite(nid_day,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2806	c call writephy(fid_day,prof2d_av,'sols',solsw,
2807	c . 'Solar rad. at surf.','W/m2')
2808	c
2809	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
2810	CALL histwrite(nid_day,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2811	c call writephy(fid_day,prof2d_av,'soll',sollw,
2812	c . 'IR rad. at surface','W/m2')
2813	c
2814	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
2815	CALL histwrite(nid_day,"solldown",itau_w,zx_tmp_2d,iim*jjmp1,
2816	. ndex2d)
2817	c call writephy(fid_day,prof2d_av,'solldown',sollwdown,
2818	c . 'Down. IR rad. at surface','W/m2')
2819	c
2820	CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
2821	CALL histwrite(nid_day,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2822	c call writephy(fid_day,prof2d_av,'bils',bils,
2823	c . 'Surf. total heat flux','W/m2')
2824	c
2825	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
2826	CALL histwrite(nid_day,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2827	c call writephy(fid_day,prof2d_av,'sens',sens,
2828	c . 'Sensible heat flux','W/m2')
2829	c
2830	CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
2831	CALL histwrite(nid_day,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2832	c call writephy(fid_day,prof2d_av,'fder',fder,
2833	c . 'Heat flux derivation','W/m2')
2834	c
2835	c
2836	DO nsrf = 1, nbsrf
2837	C§§§
2838	zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
2839	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2840	CALL histwrite(nid_day,"pourc_"//clnsurf(nsrf),itau_w,
2841	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2842	c call writephy(fid_day,prof2d_av,'pourc_'//clnsurf(nsrf),
2843	c . pctsrf( 1 : klon, nsrf),
2844	c . 'Fraction'//clnsurf(nsrf),'-')
2845	C
2846	zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
2847	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2848	CALL histwrite(nid_day,"tsol_"//clnsurf(nsrf),itau_w,
2849	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2850	c call writephy(fid_day,prof2d_av,'tsol_'//clnsurf(nsrf),
2851	c . ftsol( 1 : klon, nsrf),
2852	c . 'Surf. Temp'//clnsurf(nsrf),'K')
2853	C
2854	zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
2855	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2856	CALL histwrite(nid_day,"sens_"//clnsurf(nsrf),itau_w,
2857	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2858	c call writephy(fid_day,prof2d_av,'sens_'//clnsurf(nsrf),
2859	c . fluxt( 1 : klon, 1, nsrf),
2860	c . 'Sensible heat flux '//clnsurf(nsrf),'W/m2')
2861	C
2862	zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
2863	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2864	CALL histwrite(nid_day,"lat_"//clnsurf(nsrf),itau_w,
2865	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2866	c call writephy(fid_day,prof2d_av,'lat_'//clnsurf(nsrf),
2867	c . fluxlat( 1 : klon, nsrf),
2868	c . 'Latent heat flux '//clnsurf(nsrf),'W/m2')
2869	C
2870	zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
2871	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2872	CALL histwrite(nid_day,"taux_"//clnsurf(nsrf),itau_w,
2873	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2874	c call writephy(fid_day,prof2d_av,'taux_'//clnsurf(nsrf),
2875	c . fluxu( 1 : klon, 1, nsrf),
2876	c . 'Zonal wind stress '//clnsurf(nsrf),'Pa')
2877	C
2878	zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
2879	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2880	CALL histwrite(nid_day,"tauy_"//clnsurf(nsrf),itau_w,
2881	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2882	c call writephy(fid_day,prof2d_av,'tauy_'//clnsurf(nsrf),
2883	c . fluxv( 1 : klon, 1, nsrf),
2884	c . 'Meridional wind stress '//clnsurf(nsrf),'Pa')
2885	C
2886	zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
2887	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2888	CALL histwrite(nid_day,"albe_"//clnsurf(nsrf),itau_w,
2889	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2890	c call writephy(fid_day,prof2d_av,'albe_'//clnsurf(nsrf),
2891	c . falbe( 1 : klon, nsrf),
2892	c . 'Albedo surf. SW'//clnsurf(nsrf),'-')
2893	c call writephy(fid_day,prof2d_av,'alblw_'//clnsurf(nsrf),
2894	c . falblw( 1 : klon, nsrf),
2895	c . 'Albedo surf. LW'//clnsurf(nsrf),'-')
2896	C
2897	zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
2898	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
2899	CALL histwrite(nid_day,"rugs_"//clnsurf(nsrf),itau_w,
2900	$ zx_tmp_2d,iim*jjmp1,ndex2d)
2901	c call writephy(fid_day,prof2d_av,'rugs_'//clnsurf(nsrf),
2902	c . frugs( 1 : klon, nsrf),
2903	c . 'Rugosity '//clnsurf(nsrf),' - ')
2904	C
2905	END DO
2906	C
2907	c$$$ DO i = 1, klon
2908	c$$$ zx_tmp_fi2d(i) = pctsrf(i,is_sic)
2909	c$$$ ENDDO
2910	c$$$ CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
2911	c$$$ CALL histwrite(nid_day,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2912	c
2913	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
2914	CALL histwrite(nid_day,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2915	c call writephy(fid_day,prof2d_av,'cldl',cldl,
2916	c . 'Low-level cloudiness','-')
2917	c
2918	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
2919	CALL histwrite(nid_day,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2920	c call writephy(fid_day,prof2d_av,'cldm',cldm,
2921	c . 'Mid-level cloudiness','-')
2922	c
2923	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
2924	CALL histwrite(nid_day,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2925	c call writephy(fid_day,prof2d_av,'cldh',cldh,
2926	c . 'High-level cloudiness','-')
2927	c
2928	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
2929	CALL histwrite(nid_day,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2930	c call writephy(fid_day,prof2d_av,'cldt',cldt,
2931	c . 'Total cloudiness','-')
2932	c
2933	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
2934	CALL histwrite(nid_day,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
2935	c call writephy(fid_day,prof2d_av,'cldq',cldq,
2936	c . 'Cloud liquid water path','-')
2937	c
2938	c Champs 3D:
2939	c
2940	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
2941	CALL histwrite(nid_day,"temp",itau_w,zx_tmp_3d,
2942	. iimjjmp1klev,ndex3d)
2943	c Essai writephys
2944	varname = 'temp'
2945	vartitle= 'temperature 3D'
2946	varunits= 'K'
2947	c call writephy(fid_day,prof3d_av,varname,t_seri,vartitle,varunits)
2948	c
2949	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
2950	CALL histwrite(nid_day,"ovap",itau_w,zx_tmp_3d,
2951	. iimjjmp1klev,ndex3d)
2952	c call writephy(fid_day,prof3d_av,'ovap',qx(1,1,ivap),
2953	c . 'Specific humidity','Kg/Kg')
2954	c
2955	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
2956	CALL histwrite(nid_day,"geop",itau_w,zx_tmp_3d,
2957	. iimjjmp1klev,ndex3d)
2958	c call writephy(fid_day,prof3d_av,'geop',zphi,
2959	c . 'Geopotential height','m')
2960	c
2961	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
2962	CALL histwrite(nid_day,"vitu",itau_w,zx_tmp_3d,
2963	. iimjjmp1klev,ndex3d)
2964	c call writephy(fid_day,prof3d_av,'vitu',u_seri,
2965	c . 'Zonal wind','m/s')
2966	c
2967	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
2968	CALL histwrite(nid_day,"vitv",itau_w,zx_tmp_3d,
2969	. iimjjmp1klev,ndex3d)
2970	c call writephy(fid_day,prof3d_av,'vitv',v_seri,
2971	c . 'Meridional wind','m/s')
2972	c
2973	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
2974	CALL histwrite(nid_day,"vitw",itau_w,zx_tmp_3d,
2975	. iimjjmp1klev,ndex3d)
2976	c call writephy(fid_day,prof3d_av,'vitw',omega,
2977	c . 'Vertical wind','m/s')
2978	c
2979	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
2980	CALL histwrite(nid_day,"pres",itau_w,zx_tmp_3d,
2981	. iimjjmp1klev,ndex3d)
2982	c call writephy(fid_day,prof3d_av,'pres',pplay,
2983	c . 'Air pressure','Pa')
2984
2985	c
2986	if (ok_sync) then
2987	c call writephy_sync(fid_day)
2988	call histsync(nid_day)
2989	endif
2990	ENDIF
2991	C
2992	IF (ok_mensuel) THEN
2993	c
2994	ndex2d = 0
2995	ndex3d = 0
2996	c
2997	c Champs 2D:
2998	c
2999	zsto = dtime
3000	zout = dtime * ecrit_mth
3001	itau_w = itau_phy + itap
3002
3003	i = NINT(zout/zsto)
3004	CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
3005	CALL histwrite(nid_mth,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3006	C
3007	i = NINT(zout/zsto)
3008	CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
3009	CALL histwrite(nid_mth,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3010
3011	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
3012	CALL histwrite(nid_mth,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3013	c
3014	DO i = 1, klon
3015	zx_tmp_fi2d(i) = paprs(i,1)
3016	ENDDO
3017	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3018	CALL histwrite(nid_mth,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3019	c
3020	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsol,zx_tmp_2d)
3021	CALL histwrite(nid_mth,"qsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3022	c
3023	DO i = 1, klon
3024	zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
3025	ENDDO
3026	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3027	CALL histwrite(nid_mth,"rain",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3028	c
3029	DO i = 1, klon
3030	zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
3031	ENDDO
3032	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3033	CALL histwrite(nid_mth,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3034	c
3035	DO i = 1, klon
3036	zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
3037	ENDDO
3038	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3039	CALL histwrite(nid_mth,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3040	c
3041	CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
3042	CALL histwrite(nid_mth,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3043	c
3044	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
3045	CALL histwrite(nid_mth,"snow_cov",itau_w,zx_tmp_2d,iim*jjmp1,
3046	. ndex2d)
3047	c
3048	CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
3049	CALL histwrite(nid_mth,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3050	c
3051	CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
3052	CALL histwrite(nid_mth,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3053	c
3054	CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
3055	CALL histwrite(nid_mth,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3056	c
3057	CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
3058	CALL histwrite(nid_mth,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3059	c
3060	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
3061	CALL histwrite(nid_mth,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3062	c
3063	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
3064	CALL histwrite(nid_mth,"solldown",itau_w,zx_tmp_2d,iim*jjmp1,
3065	. ndex2d)
3066	c
3067	CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
3068	CALL histwrite(nid_mth,"tops0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3069	c
3070	CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
3071	CALL histwrite(nid_mth,"topl0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3072	c
3073	CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
3074	CALL histwrite(nid_mth,"sols0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3075	c
3076	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
3077	CALL histwrite(nid_mth,"soll0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3078	c
3079	CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
3080	CALL histwrite(nid_mth,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3081	c
3082	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
3083	CALL histwrite(nid_mth,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3084	c
3085	CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
3086	CALL histwrite(nid_mth,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3087	c
3088	c
3089	c DO i = 1, klon
3090	c zx_tmp_fi2d(i) = fluxu(i,1)
3091	c ENDDO
3092	c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3093	c CALL histwrite(nid_mth,"frtu",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3094	c
3095	c DO i = 1, klon
3096	c zx_tmp_fi2d(i) = fluxv(i,1)
3097	c ENDDO
3098	c CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3099	c CALL histwrite(nid_mth,"frtv",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3100	c
3101	DO nsrf = 1, nbsrf
3102	C§§§
3103	zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
3104	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3105	CALL histwrite(nid_mth,"pourc_"//clnsurf(nsrf),itau_w,
3106	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3107	C
3108	zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
3109	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3110	CALL histwrite(nid_mth,"tsol_"//clnsurf(nsrf),itau_w,
3111	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3112	C
3113	zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
3114	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3115	CALL histwrite(nid_mth,"sens_"//clnsurf(nsrf),itau_w,
3116	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3117	C
3118	zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
3119	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3120	CALL histwrite(nid_mth,"lat_"//clnsurf(nsrf),itau_w,
3121	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3122	C
3123	zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
3124	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3125	CALL histwrite(nid_mth,"taux_"//clnsurf(nsrf),itau_w,
3126	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3127	C
3128	zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
3129	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3130	CALL histwrite(nid_mth,"tauy_"//clnsurf(nsrf),itau_w,
3131	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3132	C
3133	zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
3134	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3135	CALL histwrite(nid_mth,"albe_"//clnsurf(nsrf),itau_w,
3136	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3137	C
3138	zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
3139	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3140	CALL histwrite(nid_mth,"rugs_"//clnsurf(nsrf),itau_w,
3141	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3142	c
3143	zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
3144	CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
3145	CALL histwrite(nid_mth,"ages_"//clnsurf(nsrf),itau_w
3146	$ ,zx_tmp_2d,iim*jjmp1,ndex2d)
3147
3148	END DO
3149	c$$$ DO i = 1, klon
3150	c$$$ zx_tmp_fi2d(i) = pctsrf(i,is_sic)
3151	c$$$ ENDDO
3152	c$$$ CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3153	c$$$ CALL histwrite(nid_mth,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3154	c
3155	CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
3156	CALL histwrite(nid_mth,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3157	CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
3158	CALL histwrite(nid_mth,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3159	c
3160	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
3161	CALL histwrite(nid_mth,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3162	c
3163	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
3164	CALL histwrite(nid_mth,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3165	c
3166	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
3167	CALL histwrite(nid_mth,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3168	c
3169	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
3170	CALL histwrite(nid_mth,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3171	c
3172	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
3173	CALL histwrite(nid_mth,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3174	c
3175	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
3176	CALL histwrite(nid_mth,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3177	c
3178	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
3179	CALL histwrite(nid_mth,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3180	c
3181	CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
3182	CALL histwrite(nid_mth,"ue",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3183	c
3184	CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
3185	CALL histwrite(nid_mth,"ve",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3186	c
3187	CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
3188	CALL histwrite(nid_mth,"uq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3189	c
3190	CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
3191	CALL histwrite(nid_mth,"vq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3192	cKE43
3193	IF (iflag_con .GE. 3) THEN ! sb
3194	c
3195	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
3196	CALL histwrite(nid_mth,"cape",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3197	c
3198	CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
3199	CALL histwrite(nid_mth,"pbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3200	c
3201	CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
3202	CALL histwrite(nid_mth,"ptop",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3203	c
3204	CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
3205	CALL histwrite(nid_mth,"fbase",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3206	c
3207	c
3208	ENDIF
3209	c34EK
3210	c
3211	c Champs 3D:
3212	C
3213	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
3214	CALL histwrite(nid_mth,"temp",itau_w,zx_tmp_3d,
3215	. iimjjmp1klev,ndex3d)
3216	c
3217	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
3218	CALL histwrite(nid_mth,"ovap",itau_w,zx_tmp_3d,
3219	. iimjjmp1klev,ndex3d)
3220	c
3221	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
3222	CALL histwrite(nid_mth,"geop",itau_w,zx_tmp_3d,
3223	. iimjjmp1klev,ndex3d)
3224	c
3225	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
3226	CALL histwrite(nid_mth,"vitu",itau_w,zx_tmp_3d,
3227	. iimjjmp1klev,ndex3d)
3228	c
3229	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
3230	CALL histwrite(nid_mth,"vitv",itau_w,zx_tmp_3d,
3231	. iimjjmp1klev,ndex3d)
3232	c
3233	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
3234	CALL histwrite(nid_mth,"vitw",itau_w,zx_tmp_3d,
3235	. iimjjmp1klev,ndex3d)
3236	c
3237	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
3238	CALL histwrite(nid_mth,"pres",itau_w,zx_tmp_3d,
3239	. iimjjmp1klev,ndex3d)
3240	c
3241	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
3242	CALL histwrite(nid_mth,"rneb",itau_w,zx_tmp_3d,
3243	. iimjjmp1klev,ndex3d)
3244	c
3245	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
3246	CALL histwrite(nid_mth,"rhum",itau_w,zx_tmp_3d,
3247	. iimjjmp1klev,ndex3d)
3248	c
3249	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
3250	CALL histwrite(nid_mth,"oliq",itau_w,zx_tmp_3d,
3251	. iimjjmp1klev,ndex3d)
3252	c
3253	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
3254	CALL histwrite(nid_mth,"dtdyn",itau_w,zx_tmp_3d,
3255	. iimjjmp1klev,ndex3d)
3256	c
3257	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
3258	CALL histwrite(nid_mth,"dqdyn",itau_w,zx_tmp_3d,
3259	. iimjjmp1klev,ndex3d)
3260	c
3261	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
3262	CALL histwrite(nid_mth,"dtcon",itau_w,zx_tmp_3d,
3263	. iimjjmp1klev,ndex3d)
3264	c
3265	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
3266	CALL histwrite(nid_mth,"dqcon",itau_w,zx_tmp_3d,
3267	. iimjjmp1klev,ndex3d)
3268	c
3269	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
3270	CALL histwrite(nid_mth,"dtlsc",itau_w,zx_tmp_3d,
3271	. iimjjmp1klev,ndex3d)
3272	c
3273	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
3274	CALL histwrite(nid_mth,"dqlsc",itau_w,zx_tmp_3d,
3275	. iimjjmp1klev,ndex3d)
3276	c
3277	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
3278	CALL histwrite(nid_mth,"dtvdf",itau_w,zx_tmp_3d,
3279	. iimjjmp1klev,ndex3d)
3280	c
3281	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
3282	CALL histwrite(nid_mth,"dqvdf",itau_w,zx_tmp_3d,
3283	. iimjjmp1klev,ndex3d)
3284	c
3285	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
3286	CALL histwrite(nid_mth,"dteva",itau_w,zx_tmp_3d,
3287	. iimjjmp1klev,ndex3d)
3288	c
3289	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
3290	CALL histwrite(nid_mth,"dqeva",itau_w,zx_tmp_3d,
3291	. iimjjmp1klev,ndex3d)
3292	c
3293	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
3294	CALL histwrite(nid_mth,"ptconv",itau_w,zx_tmp_3d,
3295	. iim(jjmp1)klev,ndex3d)
3296	c
3297	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
3298	CALL histwrite(nid_mth,"ratqs",itau_w,zx_tmp_3d,
3299	. iim(jjmp1)klev,ndex3d)
3300	c
3301	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
3302	CALL histwrite(nid_mth,"dtajs",itau_w,zx_tmp_3d,
3303	. iimjjmp1klev,ndex3d)
3304	c
3305	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
3306	CALL histwrite(nid_mth,"dqajs",itau_w,zx_tmp_3d,
3307	. iimjjmp1klev,ndex3d)
3308	c
3309	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
3310	CALL histwrite(nid_mth,"dtswr",itau_w,zx_tmp_3d,
3311	. iimjjmp1klev,ndex3d)
3312	c
3313	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
3314	CALL histwrite(nid_mth,"dtsw0",itau_w,zx_tmp_3d,
3315	. iimjjmp1klev,ndex3d)
3316	c
3317	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
3318	CALL histwrite(nid_mth,"dtlwr",itau_w,zx_tmp_3d,
3319	. iimjjmp1klev,ndex3d)
3320	c
3321	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
3322	CALL histwrite(nid_mth,"dtlw0",itau_w,zx_tmp_3d,
3323	. iimjjmp1klev,ndex3d)
3324	c
3325	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
3326	CALL histwrite(nid_mth,"duvdf",itau_w,zx_tmp_3d,
3327	. iimjjmp1klev,ndex3d)
3328	c
3329	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
3330	CALL histwrite(nid_mth,"dvvdf",itau_w,zx_tmp_3d,
3331	. iimjjmp1klev,ndex3d)
3332	c
3333	IF (ok_orodr) THEN
3334	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oro, zx_tmp_3d)
3335	CALL histwrite(nid_mth,"duoro",itau_w,zx_tmp_3d,
3336	. iimjjmp1klev,ndex3d)
3337	c
3338	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oro, zx_tmp_3d)
3339	CALL histwrite(nid_mth,"dvoro",itau_w,zx_tmp_3d,
3340	. iimjjmp1klev,ndex3d)
3341	c
3342	ENDIF
3343	C
3344	IF (ok_orolf) THEN
3345	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_lif, zx_tmp_3d)
3346	CALL histwrite(nid_mth,"dulif",itau_w,zx_tmp_3d,
3347	. iimjjmp1klev,ndex3d)
3348	c
3349	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_lif, zx_tmp_3d)
3350	CALL histwrite(nid_mth,"dvlif",itau_w,zx_tmp_3d,
3351	. iimjjmp1klev,ndex3d)
3352	ENDIF
3353	C
3354	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
3355	CALL histwrite(nid_mth,"ozone",itau_w,zx_tmp_3d,
3356	. iimjjmp1klev,ndex3d)
3357	c
3358	IF (nqmax.GE.3) THEN
3359	DO iq=1,nqmax-2
3360	IF (iq.LE.99) THEN
3361	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq+2), zx_tmp_3d)
3362	WRITE(str2,'(i2.2)') iq
3363	CALL histwrite(nid_mth,"trac"//str2,itau_w,zx_tmp_3d,
3364	. iimjjmp1klev,ndex3d)
3365	ELSE
3366	PRINT*, "Trop de traceurs"
3367	CALL abort
3368	ENDIF
3369	ENDDO
3370	ENDIF
3371	cKE43
3372	IF (iflag_con.GE.3) THEN ! (sb)
3373	c
3374	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
3375	CALL histwrite(nid_mth,"upwd",itau_w,zx_tmp_3d,
3376	. iimjjmp1klev,ndex3d)
3377	c
3378	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
3379	CALL histwrite(nid_mth,"dnwd",itau_w,zx_tmp_3d,
3380	. iimjjmp1klev,ndex3d)
3381	c
3382	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
3383	CALL histwrite(nid_mth,"dnwd0",itau_w,zx_tmp_3d,
3384	. iimjjmp1klev,ndex3d)
3385	c
3386	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
3387	CALL histwrite(nid_mth,"Ma",itau_w,zx_tmp_3d,
3388	. iimjjmp1klev,ndex3d)
3389	c
3390	c
3391	ENDIF
3392	c34EK
3393	c
3394	if (ok_sync) then
3395	call histsync(nid_mth)
3396	endif
3397	ENDIF
3398	c
3399	IF (ok_instan) THEN
3400	c
3401	ndex2d = 0
3402	ndex3d = 0
3403	c
3404	c Champs 2D:
3405	c
3406	zsto = dtime * ecrit_ins
3407	zout = dtime * ecrit_ins
3408	itau_w = itau_phy + itap
3409
3410	i = NINT(zout/zsto)
3411	CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
3412	CALL histwrite(nid_ins,"phis",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3413	c
3414	i = NINT(zout/zsto)
3415	CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
3416	CALL histwrite(nid_ins,"aire",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3417
3418	DO i = 1, klon
3419	zx_tmp_fi2d(i) = paprs(i,1)
3420	ENDDO
3421	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3422	CALL histwrite(nid_ins,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3423	c
3424	DO i = 1, klon
3425	zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
3426	ENDDO
3427	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3428	CALL histwrite(nid_ins,"rain",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3429	c
3430	DO i = 1, klon
3431	zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
3432	ENDDO
3433	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3434	CALL histwrite(nid_ins,"plul",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3435	c
3436	DO i = 1, klon
3437	zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
3438	ENDDO
3439	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
3440	CALL histwrite(nid_ins,"pluc",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3441
3442	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
3443	CALL histwrite(nid_ins,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3444	c
3445	CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
3446	CALL histwrite(nid_ins,"snow",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3447
3448	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
3449	CALL histwrite(nid_ins,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3450	c
3451	CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
3452	CALL histwrite(nid_ins,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3453	c
3454	CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
3455	CALL histwrite(nid_ins,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3456	c
3457	CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
3458	CALL histwrite(nid_ins,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3459	c
3460	CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
3461	CALL histwrite(nid_ins,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3462	c
3463	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
3464	CALL histwrite(nid_ins,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3465	c
3466	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
3467	CALL histwrite(nid_ins,"solldown",itau_w,zx_tmp_2d,iim*jjmp1,
3468	. ndex2d)
3469	c
3470	CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
3471	CALL histwrite(nid_ins,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3472	c
3473	CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
3474	CALL histwrite(nid_ins,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3475	c
3476	CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
3477	CALL histwrite(nid_ins,"fder",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3478	c
3479	CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d)
3480	CALL histwrite(nid_ins,"dtsvdfo",itau_w,zx_tmp_2d,iim*jjmp1,
3481	. ndex2d)
3482	c
3483	CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d)
3484	CALL histwrite(nid_ins,"dtsvdft",itau_w,zx_tmp_2d,iim*jjmp1,
3485	. ndex2d)
3486	c
3487	CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d)
3488	CALL histwrite(nid_ins,"dtsvdfg",itau_w,zx_tmp_2d,iim*jjmp1,
3489	. ndex2d)
3490	c
3491	CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d)
3492	CALL histwrite(nid_ins,"dtsvdfi",itau_w,zx_tmp_2d,iim*jjmp1,
3493	. ndex2d)
3494
3495	DO nsrf = 1, nbsrf
3496	C§§§
3497	zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
3498	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3499	CALL histwrite(nid_ins,"pourc_"//clnsurf(nsrf),itau_w,
3500	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3501	C
3502	zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
3503	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3504	CALL histwrite(nid_ins,"sens_"//clnsurf(nsrf),itau_w,
3505	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3506	C
3507	zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
3508	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3509	CALL histwrite(nid_ins,"lat_"//clnsurf(nsrf),itau_w,
3510	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3511	C
3512	zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
3513	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3514	CALL histwrite(nid_ins,"tsol_"//clnsurf(nsrf),itau_w,
3515	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3516	C
3517	zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
3518	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3519	CALL histwrite(nid_ins,"taux_"//clnsurf(nsrf),itau_w,
3520	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3521	C
3522	zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
3523	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3524	CALL histwrite(nid_ins,"tauy_"//clnsurf(nsrf),itau_w,
3525	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3526	C
3527	zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
3528	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3529	CALL histwrite(nid_ins,"rugs_"//clnsurf(nsrf),itau_w,
3530	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3531	C
3532	zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
3533	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
3534	CALL histwrite(nid_ins,"albe_"//clnsurf(nsrf),itau_w,
3535	$ zx_tmp_2d,iim*jjmp1,ndex2d)
3536	C
3537	END DO
3538	CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
3539	CALL histwrite(nid_ins,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3540	CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
3541	CALL histwrite(nid_ins,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3542	c
3543	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
3544	CALL histwrite(nid_ins,"snow_cov",itau_w,zx_tmp_2d,iim*jjmp1,
3545	. ndex2d)
3546	c
3547	CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
3548	CALL histwrite(nid_ins,"rugs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
3549	c
3550	c Champs 3D:
3551	c
3552	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
3553	CALL histwrite(nid_ins,"temp",itau_w,zx_tmp_3d,
3554	. iimjjmp1klev,ndex3d)
3555	c
3556	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
3557	CALL histwrite(nid_ins,"vitu",itau_w,zx_tmp_3d,
3558	. iimjjmp1klev,ndex3d)
3559	c
3560	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
3561	CALL histwrite(nid_ins,"vitv",itau_w,zx_tmp_3d,
3562	. iimjjmp1klev,ndex3d)
3563	c
3564	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
3565	CALL histwrite(nid_ins,"geop",itau_w,zx_tmp_3d,
3566	. iimjjmp1klev,ndex3d)
3567	c
3568	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
3569	CALL histwrite(nid_ins,"pres",itau_w,zx_tmp_3d,
3570	. iimjjmp1klev,ndex3d)
3571	c
3572	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
3573	CALL histwrite(nid_ins,"dtvdf",itau_w,zx_tmp_3d,
3574	. iimjjmp1klev,ndex3d)
3575	c
3576	CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
3577	CALL histwrite(nid_ins,"dqvdf",itau_w,zx_tmp_3d,
3578	. iimjjmp1klev,ndex3d)
3579
3580	c
3581	if (ok_sync) then
3582	call histsync(nid_ins)
3583	endif
3584	ENDIF
3585	c
3586	c
3587	c Ecrire la bande regionale (binaire grads)
3588	IF (ok_region .AND. mod(itap,ecrit_reg).eq.0) THEN
3589	CALL ecriregs(84,zxtsol)
3590	CALL ecriregs(84,paprs(1,1))
3591	CALL ecriregs(84,topsw)
3592	CALL ecriregs(84,toplw)
3593	CALL ecriregs(84,solsw)
3594	CALL ecriregs(84,sollw)
3595	CALL ecriregs(84,rain_fall)
3596	CALL ecriregs(84,snow_fall)
3597	CALL ecriregs(84,evap)
3598	CALL ecriregs(84,sens)
3599	CALL ecriregs(84,bils)
3600	CALL ecriregs(84,pctsrf(1,is_sic))
3601	CALL ecriregs(84,zxfluxu(1,1))
3602	CALL ecriregs(84,zxfluxv(1,1))
3603	CALL ecriregs(84,ue)
3604	CALL ecriregs(84,ve)
3605	CALL ecriregs(84,uq)
3606	CALL ecriregs(84,vq)
3607	c
3608	CALL ecrirega(84,u_seri)
3609	CALL ecrirega(84,v_seri)
3610	CALL ecrirega(84,omega)
3611	CALL ecrirega(84,t_seri)
3612	CALL ecrirega(84,zphi)
3613	CALL ecrirega(84,q_seri)
3614	CALL ecrirega(84,cldfra)
3615	CALL ecrirega(84,cldliq)
3616	CALL ecrirega(84,pplay)
3617
3618
3619	cc CALL ecrirega(84,d_t_dyn)
3620	cc CALL ecrirega(84,d_q_dyn)
3621	cc CALL ecrirega(84,heat)
3622	cc CALL ecrirega(84,cool)
3623	cc CALL ecrirega(84,d_t_con)
3624	cc CALL ecrirega(84,d_q_con)
3625	cc CALL ecrirega(84,d_t_lsc)
3626	cc CALL ecrirega(84,d_q_lsc)
3627	ENDIF
3628	c
3629	c Convertir les incrementations en tendances
3630	c
3631	DO k = 1, klev
3632	DO i = 1, klon
3633	d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
3634	d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
3635	d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
3636	d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
3637	d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
3638	ENDDO
3639	ENDDO
3640	c
3641	IF (nqmax.GE.3) THEN
3642	DO iq = 3, nqmax
3643	DO k = 1, klev
3644	DO i = 1, klon
3645	d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
3646	ENDDO
3647	ENDDO
3648	ENDDO
3649	ENDIF
3650	c
3651	c Sauvegarder les valeurs de t et q a la fin de la physique:
3652	c
3653	DO k = 1, klev
3654	DO i = 1, klon
3655	t_ancien(i,k) = t_seri(i,k)
3656	q_ancien(i,k) = q_seri(i,k)
3657	ENDDO
3658	ENDDO
3659	c
3660	c====================================================================
3661	c Si c'est la fin, il faut conserver l'etat de redemarrage
3662	c====================================================================
3663	c
3664	IF (lafin) THEN
3665	itau_phy = itau_phy + itap
3666	ccc IF (ok_oasis) CALL quitcpl
3667	CALL phyredem ("restartphy.nc",dtime,radpas,co2_ppm,solaire,
3668	. rlat, rlon, pctsrf, ftsol, ftsoil, deltat, fqsol, fsnow,
3669	. falbe, fevap, rain_fall, snow_fall,
3670	. solsw, sollwdown,dlw,
3671	. radsol,frugs,agesno,
3672	. zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,
3673	. t_ancien, q_ancien, rnebcon, ratqs, clwcon)
3674	ENDIF
3675
3676	RETURN
3677	END
3678	FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
3679	IMPLICIT none
3680	c
3681	c Calculer et imprimer l'eau totale. A utiliser pour verifier
3682	c la conservation de l'eau
3683	c
3684	#include "YOMCST.h"
3685	INTEGER klon,klev
3686	REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
3687	REAL aire(klon)
3688	REAL qtotal, zx, qcheck
3689	INTEGER i, k
3690	c
3691	zx = 0.0
3692	DO i = 1, klon
3693	zx = zx + aire(i)
3694	ENDDO
3695	qtotal = 0.0
3696	DO k = 1, klev
3697	DO i = 1, klon
3698	qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)
3699	. *(paprs(i,k)-paprs(i,k+1))/RG
3700	ENDDO
3701	ENDDO
3702	c
3703	qcheck = qtotal/zx
3704	c
3705	RETURN
3706	END
3707	SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
3708	IMPLICIT none
3709	c
3710	c Tranformer une variable de la grille physique a
3711	c la grille d'ecriture
3712	c
3713	INTEGER nfield,nlon,iim,jjmp1, jjm
3714	REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
3715	c
3716	INTEGER i, n, ig
3717	c
3718	jjm = jjmp1 - 1
3719	DO n = 1, nfield
3720	DO i=1,iim
3721	ecrit(i,n) = fi(1,n)
3722	ecrit(i+jjm*iim,n) = fi(nlon,n)
3723	ENDDO
3724	DO ig = 1, nlon - 2
3725	ecrit(iim+ig,n) = fi(1+ig,n)
3726	ENDDO
3727	ENDDO
3728	RETURN
3729	END
3730

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

Download in other formats:

Original Format