Context Navigation

physiq.F @ 346

Last change on this file since 346 was 344, checked in by lmdz, 22 years ago
Inclusion des modifs de D. Hauglustaine pour la version 1 de INCA LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 103.3 KB

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

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

Download in other formats:

Original Format