Context Navigation

physiq.F @ 263

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

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

Download in other formats:

Original Format