Context Navigation

physiq.F @ 23

Last change on this file since 23 was 23, checked in by lmdz, 25 years ago

modif de physiq et fistrlp.F pour recuperer les flux d'eau precipitante (cf Olivier)

Hauglustaine

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

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

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

Download in other formats:

Original Format