Context Navigation

physiq.F @ 122

Last change on this file since 122 was 122, checked in by lmdzadmin, 24 years ago
Suppression d'une reference a diagcld qui empeche l'edition des liens sur le Nec LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 99.6 KB

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

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

Download in other formats:

Original Format