Context Navigation

physiq.F @ 179

Last change on this file since 179 was 179, checked in by lmdzadmin, 23 years ago

Synchronisation avec version MAFO:

ajout sortie netcdf des champs echanges avec le coupleur
quelques save sur les variables (pb stack/static sur le nec)

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

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

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

Download in other formats:

Original Format