Context Navigation

guide_loc_mod.F90 @ 2773

Last change on this file since 2773 was 2160, checked in by Laurent Fairhead, 10 years ago
Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory
File size: 81.4 KB

Line
1	!
2	! $Id$
3	!
4	MODULE guide_loc_mod
5
6	!=======================================================================
7	! Auteur: F.Hourdin
8	! F. Codron 01/09
9	!=======================================================================
10
11	USE getparam
12	USE Write_Field_loc
13	use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close
14	USE parallel_lmdz
15	USE pres2lev_mod
16
17	IMPLICIT NONE
18
19	! ---------------------------------------------
20	! Declarations des cles logiques et parametres
21	! ---------------------------------------------
22	INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav
23	INTEGER, PRIVATE, SAVE :: nlevnc, guide_plevs
24	LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P
25	LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta
26	LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon
27	LOGICAL, PRIVATE, SAVE :: invert_p,invert_y,ini_anal
28	LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav,guide_modele
29
30	REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u
31	REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v
32	REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T
33	REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q
34	REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P
35
36	REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g
37	REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g
38	REAL, PRIVATE, SAVE :: tau_lon,tau_lat
39
40	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v
41	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q
42	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor
43
44	! ---------------------------------------------
45	! Variables de guidage
46	! ---------------------------------------------
47	! Variables des fichiers de guidage
48	REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2
49	REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2
50	REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2
51	REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2
52	REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: pnat1,pnat2
53	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2
54	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc
55	! Variables aux dimensions du modele
56	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2
57	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2
58	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2
59	REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2
60	REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2
61
62	INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev,ijnu,ijnv
63	INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv
64
65
66	CONTAINS
67	!=======================================================================
68
69	SUBROUTINE guide_init
70
71	USE control_mod
72
73	IMPLICIT NONE
74
75	INCLUDE "dimensions.h"
76	INCLUDE "paramet.h"
77	INCLUDE "netcdf.inc"
78
79	! For grossismx:
80	include "serre.h"
81
82	INTEGER :: error,ncidpl,rid,rcod
83	CHARACTER (len = 80) :: abort_message
84	CHARACTER (len = 20) :: modname = 'guide_init'
85
86	! ---------------------------------------------
87	! Lecture des parametres:
88	! ---------------------------------------------
89	! Variables guidees
90	CALL getpar('guide_u',.true.,guide_u,'guidage de u')
91	CALL getpar('guide_v',.true.,guide_v,'guidage de v')
92	CALL getpar('guide_T',.true.,guide_T,'guidage de T')
93	CALL getpar('guide_P',.true.,guide_P,'guidage de P')
94	CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q')
95	CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R')
96	CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta')
97
98	CALL getpar('guide_add',.false.,guide_add,'for�age constant?')
99	CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale')
100	if (guide_zon .and. abs(grossismx - 1.) > 0.01) &
101	call abort_gcm("guide_init", &
102	"zonal nudging requires grid regular in longitude", 1)
103
104	! Constantes de rappel. Unite : fraction de jour
105	CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u')
106	CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u')
107	CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v')
108	CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v')
109	CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T')
110	CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T')
111	CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q')
112	CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q')
113	CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P')
114	CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P')
115	CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie')
116	CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim')
117
118	! Sauvegarde du for�age
119	CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage')
120	CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage')
121	! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois.
122	IF (iguide_sav.GT.0) THEN
123	iguide_sav=day_step/iguide_sav
124	ELSE if (iguide_sav == 0) then
125	iguide_sav = huge(0)
126	ELSE
127	iguide_sav=day_step*iguide_sav
128	ENDIF
129
130	! Guidage regional seulement (sinon constant ou suivant le zoom)
131	CALL getpar('guide_reg',.false.,guide_reg,'guidage regional')
132	CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ')
133	CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ')
134	CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ')
135	CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ')
136	CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ')
137	CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ')
138
139	! Parametres pour lecture des fichiers
140	CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage')
141	CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert')
142	IF (iguide_int.EQ.0) THEN
143	iguide_int=1
144	ELSEIF (iguide_int.GT.0) THEN
145	iguide_int=day_step/iguide_int
146	ELSE
147	iguide_int=day_step*iguide_int
148	ENDIF
149	CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage')
150	! Pour compatibilite avec ancienne version avec guide_modele
151	CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol')
152	IF (guide_modele) THEN
153	guide_plevs=1
154	ENDIF
155	! Fin raccord
156	CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse')
157	CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses')
158	CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S')
159	CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P')
160
161	! ---------------------------------------------
162	! Determination du nombre de niveaux verticaux
163	! des fichiers guidage
164	! ---------------------------------------------
165	ncidpl=-99
166	if (guide_plevs.EQ.1) then
167	if (ncidpl.eq.-99) then
168	rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl)
169	if (rcod.NE.NF_NOERR) THEN
170	print *,'Guide: probleme -> pas de fichier apbp.nc'
171	CALL abort_gcm(modname,abort_message,1)
172	endif
173	endif
174	elseif (guide_plevs.EQ.2) then
175	if (ncidpl.EQ.-99) then
176	rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl)
177	if (rcod.NE.NF_NOERR) THEN
178	print *,'Guide: probleme -> pas de fichier P.nc'
179	CALL abort_gcm(modname,abort_message,1)
180	endif
181	endif
182	elseif (guide_u) then
183	if (ncidpl.eq.-99) then
184	rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl)
185	if (rcod.NE.NF_NOERR) THEN
186	print *,'Guide: probleme -> pas de fichier u.nc'
187	CALL abort_gcm(modname,abort_message,1)
188	endif
189	endif
190	elseif (guide_v) then
191	if (ncidpl.eq.-99) then
192	rcod=nf90_open('v.nc',nf90_nowrite,ncidpl)
193	if (rcod.NE.NF_NOERR) THEN
194	print *,'Guide: probleme -> pas de fichier v.nc'
195	CALL abort_gcm(modname,abort_message,1)
196	endif
197	endif
198	elseif (guide_T) then
199	if (ncidpl.eq.-99) then
200	rcod=nf90_open('T.nc',nf90_nowrite,ncidpl)
201	if (rcod.NE.NF_NOERR) THEN
202	print *,'Guide: probleme -> pas de fichier T.nc'
203	CALL abort_gcm(modname,abort_message,1)
204	endif
205	endif
206	elseif (guide_Q) then
207	if (ncidpl.eq.-99) then
208	rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl)
209	if (rcod.NE.NF_NOERR) THEN
210	print *,'Guide: probleme -> pas de fichier hur.nc'
211	CALL abort_gcm(modname,abort_message,1)
212	endif
213	endif
214	endif
215	error=NF_INQ_DIMID(ncidpl,'LEVEL',rid)
216	IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid)
217	IF (error.NE.NF_NOERR) THEN
218	print *,'Guide: probleme lecture niveaux pression'
219	CALL abort_gcm(modname,abort_message,1)
220	ENDIF
221	error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc)
222	print *,'Guide: nombre niveaux vert. nlevnc', nlevnc
223	rcod = nf90_close(ncidpl)
224
225	! ---------------------------------------------
226	! Allocation des variables
227	! ---------------------------------------------
228	abort_message='pb in allocation guide'
229
230	ALLOCATE(apnc(nlevnc), stat = error)
231	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
232	ALLOCATE(bpnc(nlevnc), stat = error)
233	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
234	apnc=0.;bpnc=0.
235
236	ALLOCATE(alpha_pcor(llm), stat = error)
237	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
238	ALLOCATE(alpha_u(ijb_u:ije_u), stat = error)
239	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
240	ALLOCATE(alpha_v(ijb_v:ije_v), stat = error)
241	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
242	ALLOCATE(alpha_T(ijb_u:ije_u), stat = error)
243	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
244	ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error)
245	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
246	ALLOCATE(alpha_P(ijb_u:ije_u), stat = error)
247	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
248	alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0
249
250	IF (guide_u) THEN
251	ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
252	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
253	ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error)
254	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
255	ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
256	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
257	ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error)
258	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
259	unat1=0.;unat2=0.;ugui1=0.;ugui2=0.
260	ENDIF
261
262	IF (guide_T) THEN
263	ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
264	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
265	ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error)
266	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
267	ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
268	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
269	ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error)
270	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
271	tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0.
272	ENDIF
273
274	IF (guide_Q) THEN
275	ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
276	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
277	ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error)
278	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
279	ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
280	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
281	ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error)
282	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
283	qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0.
284	ENDIF
285
286	IF (guide_v) THEN
287	ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error)
288	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
289	ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error)
290	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
291	ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error)
292	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
293	ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error)
294	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
295	vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0.
296	ENDIF
297
298	IF (guide_plevs.EQ.2) THEN
299	ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error)
300	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
301	ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error)
302	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
303	pnat1=0.;pnat2=0.;
304	ENDIF
305
306	IF (guide_P.OR.guide_plevs.EQ.1) THEN
307	ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error)
308	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
309	ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error)
310	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
311	psnat1=0.;psnat2=0.;
312	ENDIF
313	IF (guide_P) THEN
314	ALLOCATE(psgui2(ijb_u:ije_u), stat = error)
315	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
316	ALLOCATE(psgui1(ijb_u:ije_u), stat = error)
317	IF (error /= 0) CALL abort_gcm(modname,abort_message,1)
318	psgui1=0.;psgui2=0.
319	ENDIF
320
321	! ---------------------------------------------
322	! Lecture du premier etat de guidage.
323	! ---------------------------------------------
324	IF (guide_2D) THEN
325	CALL guide_read2D(1)
326	ELSE
327	CALL guide_read(1)
328	ENDIF
329	IF (guide_v) vnat1=vnat2
330	IF (guide_u) unat1=unat2
331	IF (guide_T) tnat1=tnat2
332	IF (guide_Q) qnat1=qnat2
333	IF (guide_plevs.EQ.2) pnat1=pnat2
334	IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2
335
336	END SUBROUTINE guide_init
337
338	!=======================================================================
339	SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps)
340	use exner_hyb_loc_m, only: exner_hyb_loc
341	use exner_milieu_loc_m, only: exner_milieu_loc
342	USE parallel_lmdz
343	USE control_mod
344	USE write_field_loc
345
346	IMPLICIT NONE
347
348	INCLUDE "dimensions.h"
349	INCLUDE "paramet.h"
350	INCLUDE "comconst.h"
351	INCLUDE "comvert.h"
352
353	! Variables entree
354	INTEGER, INTENT(IN) :: itau !pas de temps
355	REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse
356	REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov
357	REAL, DIMENSION (ijb_u:ije_u), INTENT(INOUT) :: ps
358
359	! Variables locales
360	LOGICAL, SAVE :: first=.TRUE.
361	!$OMP THREADPRIVATE(first)
362	LOGICAL :: f_out ! sortie guidage
363	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addu ! var aux: champ de guidage
364	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage
365	! Variables pour fonction Exner (P milieu couche)
366	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: pk
367	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: pks
368	REAL :: unskap
369	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: p ! besoin si guide_P
370	! Compteurs temps:
371	INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage
372	!$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test)
373	REAL :: ditau, dday_step
374	REAL :: tau,reste ! position entre 2 etats de guidage
375	REAL, SAVE :: factt ! pas de temps en fraction de jour
376	!$OMP THREADPRIVATE(factt)
377
378	INTEGER :: i,j,l
379	INTEGER,EXTERNAL :: OMP_GET_THREAD_NUM
380
381	!$OMP MASTER
382	ijbu=ij_begin ; ijeu=ij_end ; ijnu=ijeu-ijbu+1
383	jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1
384	ijbv=ij_begin ; ijev=ij_end ; ijnv=ijev-ijbv+1
385	jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1
386	IF (pole_sud) THEN
387	ijev=ij_end-iip1
388	jjev=jj_end-1
389	ijnv=ijev-ijbv+1
390	jjnv=jjev-jjbv+1
391	ENDIF
392	!$OMP END MASTER
393	!$OMP BARRIER
394
395	! PRINT *,'---> on rentre dans guide_main'
396	! CALL AllGather_Field(ucov,ip1jmp1,llm)
397	! CALL AllGather_Field(vcov,ip1jm,llm)
398	! CALL AllGather_Field(teta,ip1jmp1,llm)
399	! CALL AllGather_Field(ps,ip1jmp1,1)
400	! CALL AllGather_Field(q,ip1jmp1,llm)
401
402	!-----------------------------------------------------------------------
403	! Initialisations au premier passage
404	!-----------------------------------------------------------------------
405
406	IF (first) THEN
407	first=.FALSE.
408	!$OMP MASTER
409	ALLOCATE(f_addu(ijb_u:ije_u,llm) )
410	ALLOCATE(f_addv(ijb_v:ije_v,llm) )
411	ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )
412	ALLOCATE(pks(iip1,jjb_u:jje_u) )
413	ALLOCATE(p(ijb_u:ije_u,llmp1) )
414	CALL guide_init
415	!$OMP END MASTER
416	!$OMP BARRIER
417	itau_test=1001
418	step_rea=1
419	count_no_rea=0
420	! Calcul des constantes de rappel
421	factt=dtvr*iperiod/daysec
422	!$OMP MASTER
423	call tau2alpha(3, iip1, jjb_v, jje_v, factt, tau_min_v, tau_max_v, alpha_v)
424	call tau2alpha(2, iip1, jjb_u, jje_u, factt, tau_min_u, tau_max_u, alpha_u)
425	call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_T, tau_max_T, alpha_T)
426	call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_P, tau_max_P, alpha_P)
427	call tau2alpha(1, iip1, jjb_u, jje_u, factt, tau_min_Q, tau_max_Q, alpha_Q)
428	! correction de rappel dans couche limite
429	if (guide_BL) then
430	alpha_pcor(:)=1.
431	else
432	do l=1,llm
433	alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2.
434	enddo
435	endif
436	!$OMP END MASTER
437	!$OMP BARRIER
438	! ini_anal: etat initial egal au guidage
439	IF (ini_anal) THEN
440	CALL guide_interp(ps,teta)
441	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
442	DO l=1,llm
443	IF (guide_u) ucov(ijbu:ijeu,l)=ugui2(ijbu:ijeu,l)
444	IF (guide_v) vcov(ijbv:ijev,l)=ugui2(ijbv:ijev,l)
445	IF (guide_T) teta(ijbu:ijeu,l)=tgui2(ijbu:ijeu,l)
446	IF (guide_Q) q(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)
447	ENDDO
448
449	IF (guide_P) THEN
450	!$OMP MASTER
451	ps(ijbu:ijeu)=psgui2(ijbu:ijeu)
452	!$OMP END MASTER
453	!$OMP BARRIER
454	CALL pression_loc(ijnb_u,ap,bp,ps,p)
455	CALL massdair_loc(p,masse)
456	!$OMP BARRIER
457	ENDIF
458	RETURN
459	ENDIF
460
461	ENDIF !first
462
463	!-----------------------------------------------------------------------
464	! Lecture des fichiers de guidage ?
465	!-----------------------------------------------------------------------
466	IF (iguide_read.NE.0) THEN
467	ditau=real(itau)
468	dday_step=real(day_step)
469	IF (iguide_read.LT.0) THEN
470	tau=ditau/dday_step/REAL(iguide_read)
471	ELSE
472	tau=REAL(iguide_read)*ditau/dday_step
473	ENDIF
474	reste=tau-AINT(tau)
475	IF (reste.EQ.0.) THEN
476	IF (itau_test.EQ.itau) THEN
477	write(,)'deuxieme passage de advreel a itau=',itau
478	stop
479	ELSE
480	!$OMP MASTER
481	IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:)
482	IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:)
483	IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:)
484	IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:)
485	IF (guide_plevs.EQ.2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:)
486	IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu)
487	!$OMP END MASTER
488	!$OMP BARRIER
489	step_rea=step_rea+1
490	itau_test=itau
491	print*,'Lecture fichiers guidage, pas ',step_rea, &
492	'apres ',count_no_rea,' non lectures'
493	IF (guide_2D) THEN
494	!$OMP MASTER
495	CALL guide_read2D(step_rea)
496	!$OMP END MASTER
497	!$OMP BARRIER
498	ELSE
499	!$OMP MASTER
500	CALL guide_read(step_rea)
501	!$OMP END MASTER
502	!$OMP BARRIER
503	ENDIF
504	count_no_rea=0
505	ENDIF
506	ELSE
507	count_no_rea=count_no_rea+1
508
509	ENDIF
510	ENDIF !iguide_read=0
511
512	!-----------------------------------------------------------------------
513	! Interpolation et conversion des champs de guidage
514	!-----------------------------------------------------------------------
515	IF (MOD(itau,iguide_int).EQ.0) THEN
516	CALL guide_interp(ps,teta)
517	ENDIF
518	! Repartition entre 2 etats de guidage
519	IF (iguide_read.NE.0) THEN
520	tau=reste
521	ELSE
522	tau=1.
523	ENDIF
524
525	! CALL WriteField_u('ucov_guide',ucov)
526	! CALL WriteField_v('vcov_guide',vcov)
527	! CALL WriteField_u('teta_guide',teta)
528	! CALL WriteField_u('masse_guide',masse)
529
530
531	!-----------------------------------------------------------------------
532	! Ajout des champs de guidage
533	!-----------------------------------------------------------------------
534	! Sauvegarde du guidage?
535	f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav)
536	IF (f_out) THEN
537
538	!$OMP BARRIER
539	CALL pression_loc(ijnb_u,ap,bp,ps,p)
540
541	!$OMP BARRIER
542	if (pressure_exner) then
543	CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk)
544	else
545	CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk )
546	endif
547
548	!$OMP BARRIER
549
550	unskap=1./kappa
551	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
552	DO l = 1, llm
553	DO j=jjbu,jjeu
554	DO i =1, iip1
555	p(i+(j-1)iip1,l) = preff ( pk(i,j,l)/cpp) ** unskap
556	ENDDO
557	ENDDO
558	ENDDO
559
560	!!$OMP MASTER
561	! DO l=1,llm,5
562	! print*,'avant dump2d l=',l,mpi_rank,OMP_GET_THREAD_NUM()
563	! print*,'avant dump2d l=',l,mpi_rank
564	! CALL dump2d(iip1,jjnb_u,p(:,l),'ppp ')
565	! ENDDO
566	!!$OMP END MASTER
567	!!$OMP BARRIER
568
569	CALL guide_out("SP",jjp1,llm,p(ijb_u:ije_u,1:llm),1.)
570	ENDIF
571
572	if (guide_u) then
573	if (guide_add) then
574	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
575	DO l=1,llm
576	f_addu(ijbu:ijeu,l)=(1.-tau)ugui1(ijbu:ijeu,l)+tauugui2(ijbu:ijeu,l)
577	ENDDO
578	else
579	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
580	DO l=1,llm
581	f_addu(ijbu:ijeu,l)=(1.-tau)ugui1(ijbu:ijeu,l)+tauugui2(ijbu:ijeu,l)-ucov(ijbu:ijeu,l)
582	ENDDO
583	endif
584
585	! CALL WriteField_u('f_addu',f_addu)
586
587	if (guide_zon) CALL guide_zonave_u(1,llm,f_addu)
588	CALL guide_addfield_u(llm,f_addu,alpha_u)
589	! IF (f_out) CALL guide_out("ua",jjp1,llm,ugui1(ijb_u:ije_u,:),factt)
590	IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)ugui1(ijb_u:ije_u,:)+tauugui2(ijb_u:ije_u,:),factt)
591	IF (f_out) CALL guide_out("u",jjp1,llm,ucov(ijb_u:ije_u,:),factt)
592	IF (f_out) CALL guide_out("ucov",jjp1,llm,f_addu(ijb_u:ije_u,:),factt)
593	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
594	DO l=1,llm
595	ucov(ijbu:ijeu,l)=ucov(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
596	ENDDO
597
598	endif
599
600	if (guide_T) then
601	if (guide_add) then
602	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
603	DO l=1,llm
604	f_addu(ijbu:ijeu,l)=(1.-tau)tgui1(ijbu:ijeu,l)+tautgui2(ijbu:ijeu,l)
605	ENDDO
606	else
607	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
608	DO l=1,llm
609	f_addu(ijbu:ijeu,l)=(1.-tau)tgui1(ijbu:ijeu,l)+tautgui2(ijbu:ijeu,l)-teta(ijbu:ijeu,l)
610	ENDDO
611	endif
612	if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
613	CALL guide_addfield_u(llm,f_addu,alpha_T)
614	IF (f_out) CALL guide_out("teta",jjp1,llm,f_addu(:,:)/factt,factt)
615	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
616	DO l=1,llm
617	teta(ijbu:ijeu,l)=teta(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
618	ENDDO
619	endif
620
621	if (guide_P) then
622	if (guide_add) then
623	!$OMP MASTER
624	f_addu(ijbu:ijeu,1)=(1.-tau)psgui1(ijbu:ijeu)+taupsgui2(ijbu:ijeu)
625	!$OMP END MASTER
626	!$OMP BARRIER
627	else
628	!$OMP MASTER
629	f_addu(ijbu:ijeu,1)=(1.-tau)psgui1(ijbu:ijeu)+taupsgui2(ijbu:ijeu)-ps(ijbu:ijeu)
630	!$OMP END MASTER
631	!$OMP BARRIER
632	endif
633	if (guide_zon) CALL guide_zonave_u(2,1,f_addu(ijb_u:ije_u,1))
634	CALL guide_addfield_u(1,f_addu(ijb_u:ije_u,1),alpha_P)
635	! IF (f_out) CALL guide_out("ps",jjp1,1,f_addu(ijb_u:ije_u,1)/factt,factt)
636	!$OMP MASTER
637	ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_addu(ijbu:ijeu,1)
638	!$OMP END MASTER
639	!$OMP BARRIER
640	CALL pression_loc(ijnb_u,ap,bp,ps,p)
641	CALL massdair_loc(p,masse)
642	!$OMP BARRIER
643	endif
644
645	if (guide_Q) then
646	if (guide_add) then
647	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
648	DO l=1,llm
649	f_addu(ijbu:ijeu,l)=(1.-tau)qgui1(ijbu:ijeu,l)+tauqgui2(ijbu:ijeu,l)
650	ENDDO
651	else
652	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
653	DO l=1,llm
654	f_addu(ijbu:ijeu,l)=(1.-tau)qgui1(ijbu:ijeu,l)+tauqgui2(ijbu:ijeu,l)-q(ijbu:ijeu,l)
655	ENDDO
656	endif
657	if (guide_zon) CALL guide_zonave_u(2,llm,f_addu)
658	CALL guide_addfield_u(llm,f_addu,alpha_Q)
659	IF (f_out) CALL guide_out("q",jjp1,llm,f_addu(:,:)/factt,factt)
660
661	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
662	DO l=1,llm
663	q(ijbu:ijeu,l)=q(ijbu:ijeu,l)+f_addu(ijbu:ijeu,l)
664	ENDDO
665	endif
666
667	if (guide_v) then
668	if (guide_add) then
669	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
670	DO l=1,llm
671	f_addv(ijbv:ijev,l)=(1.-tau)vgui1(ijbv:ijev,l)+tauvgui2(ijbv:ijev,l)
672	ENDDO
673
674	else
675	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
676	DO l=1,llm
677	f_addv(ijbv:ijev,l)=(1.-tau)vgui1(ijbv:ijev,l)+tauvgui2(ijbv:ijev,l)-vcov(ijbv:ijev,l)
678	ENDDO
679
680	endif
681
682	if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_addv(ijb_v:ije_v,:))
683
684	CALL guide_addfield_v(llm,f_addv(ijb_v:ije_v,:),alpha_v)
685	IF (f_out) CALL guide_out("v",jjm,llm,vcov(ijb_v:ije_v,:),factt)
686	IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)vgui1(ijb_v:ije_v,:)+tauvgui2(ijb_v:ije_v,:),factt)
687	IF (f_out) CALL guide_out("vcov",jjm,llm,f_addv(:,:)/factt,factt)
688
689	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
690	DO l=1,llm
691	vcov(ijbv:ijev,l)=vcov(ijbv:ijev,l)+f_addv(ijbv:ijev,l)
692	ENDDO
693	endif
694
695	END SUBROUTINE guide_main
696
697
698	SUBROUTINE guide_addfield_u(vsize,field,alpha)
699	! field1=afield1+alphafield2
700
701	IMPLICIT NONE
702	INCLUDE "dimensions.h"
703	INCLUDE "paramet.h"
704
705	! input variables
706	INTEGER, INTENT(IN) :: vsize
707	REAL, DIMENSION(ijb_u:ije_u), INTENT(IN) :: alpha
708	REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
709
710	! Local variables
711	INTEGER :: l
712
713	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
714	DO l=1,vsize
715	field(ijbu:ijeu,l)=alpha(ijbu:ijeu)field(ijbu:ijeu,l)alpha_pcor(l)
716	ENDDO
717
718	END SUBROUTINE guide_addfield_u
719
720
721	SUBROUTINE guide_addfield_v(vsize,field,alpha)
722	! field1=afield1+alphafield2
723
724	IMPLICIT NONE
725	INCLUDE "dimensions.h"
726	INCLUDE "paramet.h"
727
728	! input variables
729	INTEGER, INTENT(IN) :: vsize
730	REAL, DIMENSION(ijb_v:ije_v), INTENT(IN) :: alpha
731	REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
732
733	! Local variables
734	INTEGER :: l
735
736	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
737	DO l=1,vsize
738	field(ijbv:ijev,l)=alpha(ijbv:ijev)field(ijbv:ijev,l)alpha_pcor(l)
739	ENDDO
740
741	END SUBROUTINE guide_addfield_v
742
743	!=======================================================================
744
745	SUBROUTINE guide_zonave_u(typ,vsize,field)
746
747	IMPLICIT NONE
748
749	INCLUDE "dimensions.h"
750	INCLUDE "paramet.h"
751	INCLUDE "comgeom.h"
752	INCLUDE "comconst.h"
753
754	! input/output variables
755	INTEGER, INTENT(IN) :: typ
756	INTEGER, INTENT(IN) :: vsize
757	REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field
758
759	! Local variables
760	LOGICAL, SAVE :: first=.TRUE.
761	!$OMP THREADPRIVATE(first)
762
763	INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
764	!$OMP THREADPRIVATE(imin,imax)
765	INTEGER :: i,j,l,ij
766	REAL, DIMENSION (iip1) :: lond ! longitude in Deg.
767	REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm ! zon-averaged field
768
769	IF (first) THEN
770	first=.FALSE.
771	!Compute domain for averaging
772	lond=rlonu*180./pi
773	imin(1)=1;imax(1)=iip1;
774	imin(2)=1;imax(2)=iip1;
775	IF (guide_reg) THEN
776	DO i=1,iim
777	IF (lond(i).LT.lon_min_g) imin(1)=i
778	IF (lond(i).LE.lon_max_g) imax(1)=i
779	ENDDO
780	lond=rlonv*180./pi
781	DO i=1,iim
782	IF (lond(i).LT.lon_min_g) imin(2)=i
783	IF (lond(i).LE.lon_max_g) imax(2)=i
784	ENDDO
785	ENDIF
786	ENDIF
787
788
789	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
790	DO l=1,vsize
791	fieldm(:,l)=0.
792	! Compute zonal average
793
794	!correction bug ici
795	! ---> a verifier
796	! ym DO j=jjbv,jjev
797	DO j=jjbu,jjeu
798	DO i=imin(typ),imax(typ)
799	ij=(j-1)*iip1+i
800	fieldm(j,l)=fieldm(j,l)+field(ij,l)
801	ENDDO
802	ENDDO
803	fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
804	! Compute forcing
805	DO j=jjbu,jjeu
806	DO i=1,iip1
807	ij=(j-1)*iip1+i
808	field(ij,l)=fieldm(j,l)
809	ENDDO
810	ENDDO
811	ENDDO
812
813	END SUBROUTINE guide_zonave_u
814
815
816	SUBROUTINE guide_zonave_v(typ,hsize,vsize,field)
817
818	IMPLICIT NONE
819
820	INCLUDE "dimensions.h"
821	INCLUDE "paramet.h"
822	INCLUDE "comgeom.h"
823	INCLUDE "comconst.h"
824
825	! input/output variables
826	INTEGER, INTENT(IN) :: typ
827	INTEGER, INTENT(IN) :: vsize
828	INTEGER, INTENT(IN) :: hsize
829	REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field
830
831	! Local variables
832	LOGICAL, SAVE :: first=.TRUE.
833	!$OMP THREADPRIVATE(first)
834	INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain
835	!$OMP THREADPRIVATE(imin, imax)
836	INTEGER :: i,j,l,ij
837	REAL, DIMENSION (iip1) :: lond ! longitude in Deg.
838	REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm ! zon-averaged field
839
840	IF (first) THEN
841	first=.FALSE.
842	!Compute domain for averaging
843	lond=rlonu*180./pi
844	imin(1)=1;imax(1)=iip1;
845	imin(2)=1;imax(2)=iip1;
846	IF (guide_reg) THEN
847	DO i=1,iim
848	IF (lond(i).LT.lon_min_g) imin(1)=i
849	IF (lond(i).LE.lon_max_g) imax(1)=i
850	ENDDO
851	lond=rlonv*180./pi
852	DO i=1,iim
853	IF (lond(i).LT.lon_min_g) imin(2)=i
854	IF (lond(i).LE.lon_max_g) imax(2)=i
855	ENDDO
856	ENDIF
857	ENDIF
858
859	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
860	DO l=1,vsize
861	! Compute zonal average
862	fieldm(:,l)=0.
863	DO j=jjbv,jjev
864	DO i=imin(typ),imax(typ)
865	ij=(j-1)*iip1+i
866	fieldm(j,l)=fieldm(j,l)+field(ij,l)
867	ENDDO
868	ENDDO
869	fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1)
870	! Compute forcing
871	DO j=jjbv,jjev
872	DO i=1,iip1
873	ij=(j-1)*iip1+i
874	field(ij,l)=fieldm(j,l)
875	ENDDO
876	ENDDO
877	ENDDO
878
879
880	END SUBROUTINE guide_zonave_v
881
882	!=======================================================================
883	SUBROUTINE guide_interp(psi,teta)
884	use exner_hyb_loc_m, only: exner_hyb_loc
885	use exner_milieu_loc_m, only: exner_milieu_loc
886	USE parallel_lmdz
887	USE mod_hallo
888	USE Bands
889	IMPLICIT NONE
890
891	include "dimensions.h"
892	include "paramet.h"
893	include "comvert.h"
894	include "comgeom2.h"
895	include "comconst.h"
896
897	REAL, DIMENSION (iip1,jjb_u:jje_u), INTENT(IN) :: psi ! Psol gcm
898	REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm
899
900	LOGICAL, SAVE :: first=.TRUE.
901	!$OMP THREADPRIVATE(first)
902	! Variables pour niveaux pression:
903	REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: plnc1,plnc2 !niveaux pression guidage
904	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: plunc,plsnc !niveaux pression modele
905	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: plvnc !niveaux pression modele
906	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: p ! pression intercouches
907	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pls, pext ! var intermediaire
908	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pbarx
909	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pbary
910	! Variables pour fonction Exner (P milieu couche)
911	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pk
912	REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:) :: pks
913	REAL :: unskap
914	! Pression de vapeur saturante
915	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:) :: qsat
916	!Variables intermediaires interpolation
917	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: zu1,zu2
918	REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: zv1,zv2
919
920	INTEGER :: i,j,l,ij
921	TYPE(Request),SAVE :: Req
922	!$OMP THREADPRIVATE(Req)
923	print *,'Guide: conversion variables guidage'
924	! -----------------------------------------------------------------
925	! Calcul des niveaux de pression champs guidage (pour T et Q)
926	! -----------------------------------------------------------------
927	IF (first) THEN
928	!$OMP MASTER
929	ALLOCATE(plnc1(iip1,jjb_u:jje_u,nlevnc) )
930	ALLOCATE(plnc2(iip1,jjb_u:jje_u,nlevnc) )
931	ALLOCATE(plunc(iip1,jjb_u:jje_u,llm) )
932	ALLOCATE(plsnc(iip1,jjb_u:jje_u,llm) )
933	ALLOCATE(plvnc(iip1,jjb_v:jje_v,llm) )
934	ALLOCATE(p(iip1,jjb_u:jje_u,llmp1) )
935	ALLOCATE(pls(iip1,jjb_u:jje_u,llm) )
936	ALLOCATE(pext(iip1,jjb_u:jje_u,llm) )
937	ALLOCATE(pbarx(iip1,jjb_u:jje_u,llm) )
938	ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) )
939	ALLOCATE(pk(iip1,jjb_u:jje_u,llm) )
940	ALLOCATE(pks (iip1,jjb_u:jje_u) )
941	ALLOCATE(qsat(ijb_u:ije_u,llm) )
942	ALLOCATE(zu1(iip1,jjb_u:jje_u,llm) )
943	ALLOCATE(zu2(iip1,jjb_u:jje_u,llm) )
944	ALLOCATE(zv1(iip1,jjb_v:jje_v,llm) )
945	ALLOCATE(zv2(iip1,jjb_v:jje_v,llm) )
946	!$OMP END MASTER
947	!$OMP BARRIER
948	ENDIF
949
950
951
952
953	IF (guide_plevs.EQ.0) THEN
954	!$OMP DO
955	DO l=1,nlevnc
956	DO j=jjbu,jjeu
957	DO i=1,iip1
958	plnc2(i,j,l)=apnc(l)
959	plnc1(i,j,l)=apnc(l)
960	ENDDO
961	ENDDO
962	ENDDO
963	ENDIF
964
965	if (first) then
966	first=.FALSE.
967	!$OMP MASTER
968	print*,'Guide: verification ordre niveaux verticaux'
969	print*,'LMDZ :'
970	do l=1,llm
971	print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. &
972	+psi(1,jjeu)*(bp(l)+bp(l+1))/2.
973	enddo
974	print*,'Fichiers guidage'
975	SELECT CASE (guide_plevs)
976	CASE (0)
977	do l=1,nlevnc
978	print*,'PL(',l,')=',plnc2(1,jjbu,l)
979	enddo
980	CASE (1)
981	DO l=1,nlevnc
982	print,'PL(',l,')=',apnc(l)+bpnc(l)psnat2(i,jjbu)
983	ENDDO
984	CASE (2)
985	do l=1,nlevnc
986	print*,'PL(',l,')=',pnat2(1,jjbu,l)
987	enddo
988	END SELECT
989	print *,'inversion de l''ordre: invert_p=',invert_p
990	if (guide_u) then
991	do l=1,nlevnc
992	print*,'U(',l,')=',unat2(1,jjbu,l)
993	enddo
994	endif
995	if (guide_T) then
996	do l=1,nlevnc
997	print*,'T(',l,')=',tnat2(1,jjbu,l)
998	enddo
999	endif
1000	!$OMP END MASTER
1001	endif
1002
1003	! -----------------------------------------------------------------
1004	! Calcul niveaux pression modele
1005	! -----------------------------------------------------------------
1006
1007	! .... Calcul de pls , pression au milieu des couches ,en Pascals
1008	IF (guide_plevs.EQ.1) THEN
1009	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1010	DO l=1,llm
1011	DO j=jjbu,jjeu
1012	DO i =1, iip1
1013	pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2.
1014	ENDDO
1015	ENDDO
1016	ENDDO
1017	ELSE
1018	CALL pression_loc( ijnb_u, ap, bp, psi, p )
1019	if (disvert_type==1) then
1020	CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk)
1021	else ! we assume that we are in the disvert_type==2 case
1022	CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk)
1023	endif
1024	unskap=1./kappa
1025	!$OMP BARRIER
1026	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1027	DO l = 1, llm
1028	DO j=jjbu,jjeu
1029	DO i =1, iip1
1030	pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
1031	ENDDO
1032	ENDDO
1033	ENDDO
1034	ENDIF
1035
1036	! calcul des pressions pour les grilles u et v
1037	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1038	do l=1,llm
1039	do j=jjbu,jjeu
1040	do i=1,iip1
1041	pext(i,j,l)=pls(i,j,l)*aire(i,j)
1042	enddo
1043	enddo
1044	enddo
1045
1046	CALL Register_Hallo_u(pext,llm,1,2,2,1,Req)
1047	CALL SendRequest(Req)
1048	!$OMP BARRIER
1049	CALL WaitRequest(Req)
1050	!$OMP BARRIER
1051
1052	call massbar_loc(pext, pbarx, pbary )
1053	!$OMP BARRIER
1054	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1055	do l=1,llm
1056	do j=jjbu,jjeu
1057	do i=1,iip1
1058	plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j)
1059	plsnc(i,j,l)=pls(i,j,l)
1060	enddo
1061	enddo
1062	enddo
1063	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1064	do l=1,llm
1065	do j=jjbv,jjev
1066	do i=1,iip1
1067	plvnc(i,j,l)=pbary(i,j,l)/airev(i,j)
1068	enddo
1069	enddo
1070	enddo
1071
1072	! -----------------------------------------------------------------
1073	! Interpolation verticale champs guidage sur niveaux modele
1074	! Conversion en variables gcm (ucov, vcov...)
1075	! -----------------------------------------------------------------
1076	if (guide_P) then
1077	!$OMP MASTER
1078	do j=jjbu,jjeu
1079	do i=1,iim
1080	ij=(j-1)*iip1+i
1081	psgui1(ij)=psnat1(i,j)
1082	psgui2(ij)=psnat2(i,j)
1083	enddo
1084	psgui1(iip1*j)=psnat1(1,j)
1085	psgui2(iip1*j)=psnat2(1,j)
1086	enddo
1087	!$OMP END MASTER
1088	!$OMP BARRIER
1089	endif
1090
1091	IF (guide_T) THEN
1092	! Calcul des nouvelles valeurs des niveaux de pression du guidage
1093	IF (guide_plevs.EQ.1) THEN
1094	!$OMP DO
1095	DO l=1,nlevnc
1096	DO j=jjbu,jjeu
1097	DO i=1,iip1
1098	plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
1099	plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
1100	ENDDO
1101	ENDDO
1102	ENDDO
1103	ELSE IF (guide_plevs.EQ.2) THEN
1104	!$OMP DO
1105	DO l=1,nlevnc
1106	DO j=jjbu,jjeu
1107	DO i=1,iip1
1108	plnc2(i,j,l)=pnat2(i,j,l)
1109	plnc1(i,j,l)=pnat1(i,j,l)
1110	ENDDO
1111	ENDDO
1112	ENDDO
1113	ENDIF
1114
1115	! Interpolation verticale
1116	!$OMP MASTER
1117	CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, &
1118	plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1119	CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, &
1120	plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1121	!$OMP END MASTER
1122	!$OMP BARRIER
1123	! Conversion en variables GCM
1124	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1125	do l=1,llm
1126	do j=jjbu,jjeu
1127	IF (guide_teta) THEN
1128	do i=1,iim
1129	ij=(j-1)*iip1+i
1130	tgui1(ij,l)=zu1(i,j,l)
1131	tgui2(ij,l)=zu2(i,j,l)
1132	enddo
1133	ELSE
1134	do i=1,iim
1135	ij=(j-1)*iip1+i
1136	tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l)
1137	tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l)
1138	enddo
1139	ENDIF
1140	tgui1(jiip1,l)=tgui1((j-1)iip1+1,l)
1141	tgui2(jiip1,l)=tgui2((j-1)iip1+1,l)
1142	enddo
1143	if (pole_nord) then
1144	do i=1,iip1
1145	tgui1(i,l)=tgui1(1,l)
1146	tgui2(i,l)=tgui2(1,l)
1147	enddo
1148	endif
1149	if (pole_sud) then
1150	do i=1,iip1
1151	tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l)
1152	tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l)
1153	enddo
1154	endif
1155	enddo
1156	ENDIF
1157
1158	IF (guide_Q) THEN
1159	! Calcul des nouvelles valeurs des niveaux de pression du guidage
1160	IF (guide_plevs.EQ.1) THEN
1161	!$OMP DO
1162	DO l=1,nlevnc
1163	DO j=jjbu,jjeu
1164	DO i=1,iip1
1165	plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j)
1166	plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j)
1167	ENDDO
1168	ENDDO
1169	ENDDO
1170	ELSE IF (guide_plevs.EQ.2) THEN
1171	!$OMP DO
1172	DO l=1,nlevnc
1173	DO j=jjbu,jjeu
1174	DO i=1,iip1
1175	plnc2(i,j,l)=pnat2(i,j,l)
1176	plnc1(i,j,l)=pnat1(i,j,l)
1177	ENDDO
1178	ENDDO
1179	ENDDO
1180	ENDIF
1181
1182	! Interpolation verticale
1183	!$OMP MASTER
1184	CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, &
1185	plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1186	CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, &
1187	plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1188	!$OMP END MASTER
1189	!$OMP BARRIER
1190
1191	! Conversion en variables GCM
1192	! On suppose qu'on a la bonne variable dans le fichier de guidage:
1193	! Hum.Rel si guide_hr, Hum.Spec. sinon.
1194	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1195	do l=1,llm
1196	do j=jjbu,jjeu
1197	do i=1,iim
1198	ij=(j-1)*iip1+i
1199	qgui1(ij,l)=zu1(i,j,l)
1200	qgui2(ij,l)=zu2(i,j,l)
1201	enddo
1202	qgui1(jiip1,l)=qgui1((j-1)iip1+1,l)
1203	qgui2(jiip1,l)=qgui2((j-1)iip1+1,l)
1204	enddo
1205	if (pole_nord) then
1206	do i=1,iip1
1207	qgui1(i,l)=qgui1(1,l)
1208	qgui2(i,l)=qgui2(1,l)
1209	enddo
1210	endif
1211	if (pole_nord) then
1212	do i=1,iip1
1213	qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l)
1214	qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l)
1215	enddo
1216	endif
1217	enddo
1218	IF (guide_hr) THEN
1219	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1220	do l=1,llm
1221	CALL q_sat(iip1jjnu,teta(:,jjbu:jjeu,l)pk(:,jjbu:jjeu,l)/cpp, &
1222	plsnc(:,jjbu:jjeu,l),qsat(ijbu:ijeu,l))
1223	qgui1(ijbu:ijeu,l)=qgui1(ijbu:ijeu,l)qsat(ijbu:ijeu,l)0.01 !hum. rel. en %
1224	qgui2(ijbu:ijeu,l)=qgui2(ijbu:ijeu,l)qsat(ijbu:ijeu,l)0.01
1225	enddo
1226
1227	ENDIF
1228	ENDIF
1229
1230	IF (guide_u) THEN
1231	! Calcul des nouvelles valeurs des niveaux de pression du guidage
1232	IF (guide_plevs.EQ.1) THEN
1233	!$OMP DO
1234	DO l=1,nlevnc
1235	DO j=jjbu,jjeu
1236	DO i=1,iim
1237	plnc2(i,j,l)=apnc(l)+bpnc(l)(psnat2(i,j)aire(i,j)*alpha1p2(i,j) &
1238	& +psnat2(i+1,j)aire(i+1,j)alpha3p4(i+1,j))/aireu(i,j)
1239	plnc1(i,j,l)=apnc(l)+bpnc(l)(psnat1(i,j)aire(i,j)*alpha1p2(i,j) &
1240	& +psnat1(i+1,j)aire(i+1,j)alpha3p4(i+1,j))/aireu(i,j)
1241	ENDDO
1242	plnc2(iip1,j,l)=plnc2(1,j,l)
1243	plnc1(iip1,j,l)=plnc1(1,j,l)
1244	ENDDO
1245	ENDDO
1246	ELSE IF (guide_plevs.EQ.2) THEN
1247	!$OMP DO
1248	DO l=1,nlevnc
1249	DO j=jjbu,jjeu
1250	DO i=1,iim
1251	plnc2(i,j,l)=(pnat2(i,j,l)aire(i,j)alpha1p2(i,j) &
1252	& +pnat2(i+1,j,l)aire(i,j)alpha3p4(i+1,j))/aireu(i,j)
1253	plnc1(i,j,l)=(pnat1(i,j,l)aire(i,j)alpha1p2(i,j) &
1254	& +pnat1(i+1,j,l)aire(i,j)alpha3p4(i+1,j))/aireu(i,j)
1255	ENDDO
1256	plnc2(iip1,j,l)=plnc2(1,j,l)
1257	plnc1(iip1,j,l)=plnc1(1,j,l)
1258	ENDDO
1259	ENDDO
1260	ENDIF
1261
1262	! Interpolation verticale
1263	!$OMP MASTER
1264	CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, &
1265	plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1266	CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, &
1267	plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p)
1268	!$OMP END MASTER
1269	!$OMP BARRIER
1270
1271	! Conversion en variables GCM
1272	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1273	do l=1,llm
1274	do j=jjbu,jjeu
1275	do i=1,iim
1276	ij=(j-1)*iip1+i
1277	ugui1(ij,l)=zu1(i,j,l)*cu(i,j)
1278	ugui2(ij,l)=zu2(i,j,l)*cu(i,j)
1279	enddo
1280	ugui1(jiip1,l)=ugui1((j-1)iip1+1,l)
1281	ugui2(jiip1,l)=ugui2((j-1)iip1+1,l)
1282	enddo
1283	if (pole_nord) then
1284	do i=1,iip1
1285	ugui1(i,l)=0.
1286	ugui2(i,l)=0.
1287	enddo
1288	endif
1289	if (pole_sud) then
1290	do i=1,iip1
1291	ugui1(ip1jm+i,l)=0.
1292	ugui2(ip1jm+i,l)=0.
1293	enddo
1294	endif
1295	enddo
1296	ENDIF
1297
1298	IF (guide_v) THEN
1299	! Calcul des nouvelles valeurs des niveaux de pression du guidage
1300	IF (guide_plevs.EQ.1) THEN
1301	CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req)
1302	CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req)
1303	CALL SendRequest(Req)
1304	!$OMP BARRIER
1305	CALL WaitRequest(Req)
1306	!$OMP BARRIER
1307	!$OMP DO
1308	DO l=1,nlevnc
1309	DO j=jjbv,jjev
1310	DO i=1,iip1
1311	plnc2(i,j,l)=apnc(l)+bpnc(l)(psnat2(i,j)aire(i,j)*alpha2p3(i,j) &
1312	& +psnat2(i,j+1)aire(i,j+1)alpha1p4(i,j+1))/airev(i,j)
1313	plnc1(i,j,l)=apnc(l)+bpnc(l)(psnat1(i,j)aire(i,j)*alpha2p3(i,j) &
1314	& +psnat1(i,j+1)aire(i,j+1)alpha1p4(i,j+1))/airev(i,j)
1315	ENDDO
1316	ENDDO
1317	ENDDO
1318	ELSE IF (guide_plevs.EQ.2) THEN
1319	CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req)
1320	CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req)
1321	CALL SendRequest(Req)
1322	!$OMP BARRIER
1323	CALL WaitRequest(Req)
1324	!$OMP BARRIER
1325	!$OMP DO
1326	DO l=1,nlevnc
1327	DO j=jjbv,jjev
1328	DO i=1,iip1
1329	plnc2(i,j,l)=(pnat2(i,j,l)aire(i,j)alpha2p3(i,j) &
1330	& +pnat2(i,j+1,l)aire(i,j)alpha1p4(i,j+1))/airev(i,j)
1331	plnc1(i,j,l)=(pnat1(i,j,l)aire(i,j)alpha2p3(i,j) &
1332	& +pnat1(i,j+1,l)aire(i,j)alpha1p4(i,j+1))/airev(i,j)
1333	ENDDO
1334	ENDDO
1335	ENDDO
1336	ENDIF
1337	! Interpolation verticale
1338
1339	!$OMP MASTER
1340	CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm, &
1341	plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
1342	CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm, &
1343	plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p)
1344	!$OMP END MASTER
1345	!$OMP BARRIER
1346	! Conversion en variables GCM
1347	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
1348	do l=1,llm
1349	do j=jjbv,jjev
1350	do i=1,iim
1351	ij=(j-1)*iip1+i
1352	vgui1(ij,l)=zv1(i,j,l)*cv(i,j)
1353	vgui2(ij,l)=zv2(i,j,l)*cv(i,j)
1354	enddo
1355	vgui1(jiip1,l)=vgui1((j-1)iip1+1,l)
1356	vgui2(jiip1,l)=vgui2((j-1)iip1+1,l)
1357	enddo
1358	enddo
1359	ENDIF
1360
1361
1362	END SUBROUTINE guide_interp
1363
1364	!=======================================================================
1365	SUBROUTINE tau2alpha(typ,pim,jjb,jje,factt,taumin,taumax,alpha)
1366
1367	! Calcul des constantes de rappel alpha (=1/tau)
1368
1369	implicit none
1370
1371	include "dimensions.h"
1372	include "paramet.h"
1373	include "comconst.h"
1374	include "comgeom2.h"
1375	include "serre.h"
1376
1377	! input arguments :
1378	INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1)
1379	INTEGER, INTENT(IN) :: pim ! dimensions en lon
1380	INTEGER, INTENT(IN) :: jjb,jje ! dimensions en lat
1381	REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour
1382	REAL, INTENT(IN) :: taumin,taumax
1383	! output arguments:
1384	REAL, DIMENSION(pim,jjb:jje), INTENT(OUT) :: alpha
1385
1386	! local variables:
1387	LOGICAL, SAVE :: first=.TRUE.
1388	REAL, SAVE :: gamma,dxdy_min,dxdy_max
1389	REAL, DIMENSION (iip1,jjp1) :: zdx,zdy
1390	REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu
1391	REAL, DIMENSION (iip1,jjm) :: dxdyv
1392	real dxdy_
1393	real zlat,zlon
1394	real alphamin,alphamax,xi
1395	integer i,j,ilon,ilat
1396
1397
1398	alphamin=factt/taumax
1399	alphamax=factt/taumin
1400	IF (guide_reg.OR.guide_add) THEN
1401	alpha=alphamax
1402	!-----------------------------------------------------------------------
1403	! guide_reg: alpha=alpha_min dans region, 0. sinon.
1404	!-----------------------------------------------------------------------
1405	IF (guide_reg) THEN
1406	do j=jjb,jje
1407	do i=1,pim
1408	if (typ.eq.2) then
1409	zlat=rlatu(j)*180./pi
1410	zlon=rlonu(i)*180./pi
1411	elseif (typ.eq.1) then
1412	zlat=rlatu(j)*180./pi
1413	zlon=rlonv(i)*180./pi
1414	elseif (typ.eq.3) then
1415	zlat=rlatv(j)*180./pi
1416	zlon=rlonv(i)*180./pi
1417	endif
1418	alpha(i,j)=alphamax/16.* &
1419	(1.+tanh((zlat-lat_min_g)/tau_lat))* &
1420	(1.+tanh((lat_max_g-zlat)/tau_lat))* &
1421	(1.+tanh((zlon-lon_min_g)/tau_lon))* &
1422	(1.+tanh((lon_max_g-zlon)/tau_lon))
1423	enddo
1424	enddo
1425	ENDIF
1426	ELSE
1427	!-----------------------------------------------------------------------
1428	! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom.
1429	!-----------------------------------------------------------------------
1430	!Calcul de l'aire des mailles
1431	do j=2,jjm
1432	do i=2,iip1
1433	zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j))
1434	enddo
1435	zdx(1,j)=zdx(iip1,j)
1436	enddo
1437	do j=2,jjm
1438	do i=1,iip1
1439	zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j))
1440	enddo
1441	enddo
1442	do i=1,iip1
1443	zdx(i,1)=zdx(i,2)
1444	zdx(i,jjp1)=zdx(i,jjm)
1445	zdy(i,1)=zdy(i,2)
1446	zdy(i,jjp1)=zdy(i,jjm)
1447	enddo
1448	do j=1,jjp1
1449	do i=1,iip1
1450	dxdys(i,j)=sqrt(zdx(i,j)zdx(i,j)+zdy(i,j)zdy(i,j))
1451	enddo
1452	enddo
1453	IF (typ.EQ.2) THEN
1454	do j=1,jjp1
1455	do i=1,iim
1456	dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j))
1457	enddo
1458	dxdyu(iip1,j)=dxdyu(1,j)
1459	enddo
1460	ENDIF
1461	IF (typ.EQ.3) THEN
1462	do j=1,jjm
1463	do i=1,iip1
1464	dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1))
1465	enddo
1466	enddo
1467	ENDIF
1468	! Premier appel: calcul des aires min et max et de gamma.
1469	IF (first) THEN
1470	first=.FALSE.
1471	! coordonnees du centre du zoom
1472	CALL coordij(clon,clat,ilon,ilat)
1473	! aire de la maille au centre du zoom
1474	dxdy_min=dxdys(ilon,ilat)
1475	! dxdy maximale de la maille
1476	dxdy_max=0.
1477	do j=1,jjp1
1478	do i=1,iip1
1479	dxdy_max=max(dxdy_max,dxdys(i,j))
1480	enddo
1481	enddo
1482	! Calcul de gamma
1483	if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
1484	print*,'ATTENTION modele peu zoome'
1485	print*,'ATTENTION on prend une constante de guidage cste'
1486	gamma=0.
1487	else
1488	gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min)
1489	print*,'gamma=',gamma
1490	if (gamma.lt.1.e-5) then
1491	print*,'gamma =',gamma,'<1e-5'
1492	stop
1493	endif
1494	gamma=log(0.5)/log(gamma)
1495	if (gamma4) then
1496	gamma=min(gamma,4.)
1497	endif
1498	print*,'gamma=',gamma
1499	endif
1500	ENDIF !first
1501
1502	do j=jjb,jje
1503	do i=1,pim
1504	if (typ.eq.1) then
1505	dxdy_=dxdys(i,j)
1506	zlat=rlatu(j)*180./pi
1507	elseif (typ.eq.2) then
1508	dxdy_=dxdyu(i,j)
1509	zlat=rlatu(j)*180./pi
1510	elseif (typ.eq.3) then
1511	dxdy_=dxdyv(i,j)
1512	zlat=rlatv(j)*180./pi
1513	endif
1514	if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then
1515	! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin
1516	alpha(i,j)=alphamin
1517	else
1518	xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma
1519	xi=min(xi,1.)
1520	if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then
1521	alpha(i,j)=xialphamin+(1.-xi)alphamax
1522	else
1523	alpha(i,j)=0.
1524	endif
1525	endif
1526	enddo
1527	enddo
1528	ENDIF ! guide_reg
1529
1530	if (.not. guide_add) alpha = 1. - exp(- alpha)
1531
1532	END SUBROUTINE tau2alpha
1533
1534	!=======================================================================
1535	SUBROUTINE guide_read(timestep)
1536
1537	IMPLICIT NONE
1538
1539	#include "netcdf.inc"
1540	#include "dimensions.h"
1541	#include "paramet.h"
1542
1543	INTEGER, INTENT(IN) :: timestep
1544
1545	LOGICAL, SAVE :: first=.TRUE.
1546	! Identification fichiers et variables NetCDF:
1547	INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp
1548	INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
1549	INTEGER :: ncidpl,varidpl,varidap,varidbp
1550	! Variables auxiliaires NetCDF:
1551	INTEGER, DIMENSION(4) :: start,count
1552	INTEGER :: status,rcode
1553	CHARACTER (len = 80) :: abort_message
1554	CHARACTER (len = 20) :: modname = 'guide_read'
1555	abort_message='pb in guide_read'
1556
1557	! -----------------------------------------------------------------
1558	! Premier appel: initialisation de la lecture des fichiers
1559	! -----------------------------------------------------------------
1560	if (first) then
1561	ncidpl=-99
1562	print*,'Guide: ouverture des fichiers guidage '
1563	! Ap et Bp si Niveaux de pression hybrides
1564	if (guide_plevs.EQ.1) then
1565	print *,'Lecture du guidage sur niveaux modele'
1566	rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
1567	IF (rcode.NE.NF_NOERR) THEN
1568	print *,'Guide: probleme -> pas de fichier apbp.nc'
1569	CALL abort_gcm(modname,abort_message,1)
1570	ENDIF
1571	rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
1572	IF (rcode.NE.NF_NOERR) THEN
1573	print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
1574	CALL abort_gcm(modname,abort_message,1)
1575	ENDIF
1576	rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
1577	IF (rcode.NE.NF_NOERR) THEN
1578	print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
1579	CALL abort_gcm(modname,abort_message,1)
1580	ENDIF
1581	print*,'ncidpl,varidap',ncidpl,varidap
1582	endif
1583	! Pression si guidage sur niveaux P variables
1584	if (guide_plevs.EQ.2) then
1585	rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
1586	IF (rcode.NE.NF_NOERR) THEN
1587	print *,'Guide: probleme -> pas de fichier P.nc'
1588	CALL abort_gcm(modname,abort_message,1)
1589	ENDIF
1590	rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
1591	IF (rcode.NE.NF_NOERR) THEN
1592	print *,'Guide: probleme -> pas de variable PRES, fichier P.nc'
1593	CALL abort_gcm(modname,abort_message,1)
1594	ENDIF
1595	print*,'ncidp,varidp',ncidp,varidp
1596	if (ncidpl.eq.-99) ncidpl=ncidp
1597	endif
1598	! Vent zonal
1599	if (guide_u) then
1600	rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
1601	IF (rcode.NE.NF_NOERR) THEN
1602	print *,'Guide: probleme -> pas de fichier u.nc'
1603	CALL abort_gcm(modname,abort_message,1)
1604	ENDIF
1605	rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
1606	IF (rcode.NE.NF_NOERR) THEN
1607	print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
1608	CALL abort_gcm(modname,abort_message,1)
1609	ENDIF
1610	print*,'ncidu,varidu',ncidu,varidu
1611	if (ncidpl.eq.-99) ncidpl=ncidu
1612	endif
1613	! Vent meridien
1614	if (guide_v) then
1615	rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
1616	IF (rcode.NE.NF_NOERR) THEN
1617	print *,'Guide: probleme -> pas de fichier v.nc'
1618	CALL abort_gcm(modname,abort_message,1)
1619	ENDIF
1620	rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
1621	IF (rcode.NE.NF_NOERR) THEN
1622	print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
1623	CALL abort_gcm(modname,abort_message,1)
1624	ENDIF
1625	print*,'ncidv,varidv',ncidv,varidv
1626	if (ncidpl.eq.-99) ncidpl=ncidv
1627	endif
1628	! Temperature
1629	if (guide_T) then
1630	rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
1631	IF (rcode.NE.NF_NOERR) THEN
1632	print *,'Guide: probleme -> pas de fichier T.nc'
1633	CALL abort_gcm(modname,abort_message,1)
1634	ENDIF
1635	rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
1636	IF (rcode.NE.NF_NOERR) THEN
1637	print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
1638	CALL abort_gcm(modname,abort_message,1)
1639	ENDIF
1640	print*,'ncidT,varidT',ncidt,varidt
1641	if (ncidpl.eq.-99) ncidpl=ncidt
1642	endif
1643	! Humidite
1644	if (guide_Q) then
1645	rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
1646	IF (rcode.NE.NF_NOERR) THEN
1647	print *,'Guide: probleme -> pas de fichier hur.nc'
1648	CALL abort_gcm(modname,abort_message,1)
1649	ENDIF
1650	rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
1651	IF (rcode.NE.NF_NOERR) THEN
1652	print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
1653	CALL abort_gcm(modname,abort_message,1)
1654	ENDIF
1655	print*,'ncidQ,varidQ',ncidQ,varidQ
1656	if (ncidpl.eq.-99) ncidpl=ncidQ
1657	endif
1658	! Pression de surface
1659	if ((guide_P).OR.(guide_plevs.EQ.1)) then
1660	rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
1661	IF (rcode.NE.NF_NOERR) THEN
1662	print *,'Guide: probleme -> pas de fichier ps.nc'
1663	CALL abort_gcm(modname,abort_message,1)
1664	ENDIF
1665	rcode = nf90_inq_varid(ncidps, 'SP', varidps)
1666	IF (rcode.NE.NF_NOERR) THEN
1667	print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
1668	CALL abort_gcm(modname,abort_message,1)
1669	ENDIF
1670	print*,'ncidps,varidps',ncidps,varidps
1671	endif
1672	! Coordonnee verticale
1673	if (guide_plevs.EQ.0) then
1674	rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
1675	IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
1676	print*,'ncidpl,varidpl',ncidpl,varidpl
1677	endif
1678	! Coefs ap, bp pour calcul de la pression aux differents niveaux
1679	IF (guide_plevs.EQ.1) THEN
1680	#ifdef NC_DOUBLE
1681	status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
1682	status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
1683	#else
1684	status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
1685	status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
1686	#endif
1687	ELSEIF (guide_plevs.EQ.0) THEN
1688	#ifdef NC_DOUBLE
1689	status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
1690	#else
1691	status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
1692	#endif
1693	apnc=apnc*100.! conversion en Pascals
1694	bpnc(:)=0.
1695	ENDIF
1696	first=.FALSE.
1697	ENDIF ! (first)
1698
1699	! -----------------------------------------------------------------
1700	! lecture des champs u, v, T, Q, ps
1701	! -----------------------------------------------------------------
1702
1703	! dimensions pour les champs scalaires et le vent zonal
1704	start(1)=1
1705	start(2)=jjb_u
1706	start(3)=1
1707	start(4)=timestep
1708
1709	count(1)=iip1
1710	count(2)=jjnb_u
1711	count(3)=nlevnc
1712	count(4)=1
1713
1714	IF (invert_y) start(2)=jjp1-jje_u+1
1715	! Pression
1716	if (guide_plevs.EQ.2) then
1717	#ifdef NC_DOUBLE
1718	status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2)
1719	#else
1720	status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2)
1721	#endif
1722	IF (invert_y) THEN
1723	! PRINT*,"Invertion impossible actuellement"
1724	! CALL abort_gcm(modname,abort_message,1)
1725	CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
1726	ENDIF
1727	endif
1728
1729	! Vent zonal
1730	if (guide_u) then
1731	#ifdef NC_DOUBLE
1732	status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2)
1733	#else
1734	status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2)
1735	#endif
1736	IF (invert_y) THEN
1737	! PRINT*,"Invertion impossible actuellement"
1738	! CALL abort_gcm(modname,abort_message,1)
1739	CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
1740	ENDIF
1741
1742	endif
1743
1744
1745	! Temperature
1746	if (guide_T) then
1747	#ifdef NC_DOUBLE
1748	status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2)
1749	#else
1750	status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2)
1751	#endif
1752	IF (invert_y) THEN
1753	! PRINT*,"Invertion impossible actuellement"
1754	! CALL abort_gcm(modname,abort_message,1)
1755	CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
1756	ENDIF
1757	endif
1758
1759	! Humidite
1760	if (guide_Q) then
1761	#ifdef NC_DOUBLE
1762	status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2)
1763	#else
1764	status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2)
1765	#endif
1766	IF (invert_y) THEN
1767	! PRINT*,"Invertion impossible actuellement"
1768	! CALL abort_gcm(modname,abort_message,1)
1769	CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
1770	ENDIF
1771
1772	endif
1773
1774	! Vent meridien
1775	if (guide_v) then
1776	start(2)=jjb_v
1777	count(2)=jjnb_v
1778	IF (invert_y) start(2)=jjm-jje_v+1
1779
1780	#ifdef NC_DOUBLE
1781	status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2)
1782	#else
1783	status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2)
1784	#endif
1785	IF (invert_y) THEN
1786	! PRINT*,"Invertion impossible actuellement"
1787	! CALL abort_gcm(modname,abort_message,1)
1788	CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
1789	ENDIF
1790	endif
1791
1792	! Pression de surface
1793	if ((guide_P).OR.(guide_plevs.EQ.1)) then
1794	start(2)=jjb_u
1795	start(3)=timestep
1796	start(4)=0
1797	count(2)=jjnb_u
1798	count(3)=1
1799	count(4)=0
1800	IF (invert_y) start(2)=jjp1-jje_u+1
1801	#ifdef NC_DOUBLE
1802	status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2)
1803	#else
1804	status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2)
1805	#endif
1806	IF (invert_y) THEN
1807	! PRINT*,"Invertion impossible actuellement"
1808	! CALL abort_gcm(modname,abort_message,1)
1809	CALL invert_lat(iip1,jjnb_u,1,psnat2)
1810	ENDIF
1811	endif
1812
1813	END SUBROUTINE guide_read
1814
1815	!=======================================================================
1816	SUBROUTINE guide_read2D(timestep)
1817
1818	IMPLICIT NONE
1819
1820	#include "netcdf.inc"
1821	#include "dimensions.h"
1822	#include "paramet.h"
1823
1824	INTEGER, INTENT(IN) :: timestep
1825
1826	LOGICAL, SAVE :: first=.TRUE.
1827	! Identification fichiers et variables NetCDF:
1828	INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp
1829	INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps
1830	INTEGER :: ncidpl,varidpl,varidap,varidbp
1831	! Variables auxiliaires NetCDF:
1832	INTEGER, DIMENSION(4) :: start,count
1833	INTEGER :: status,rcode
1834	! Variables for 3D extension:
1835	REAL, DIMENSION (jjb_u:jje_u,llm) :: zu
1836	REAL, DIMENSION (jjb_v:jje_v,llm) :: zv
1837	INTEGER :: i
1838	CHARACTER (len = 80) :: abort_message
1839	CHARACTER (len = 20) :: modname = 'guide_read2D'
1840	abort_message='pb in guide_read2D'
1841
1842	! -----------------------------------------------------------------
1843	! Premier appel: initialisation de la lecture des fichiers
1844	! -----------------------------------------------------------------
1845	if (first) then
1846	ncidpl=-99
1847	print*,'Guide: ouverture des fichiers guidage '
1848	! Ap et Bp si niveaux de pression hybrides
1849	if (guide_plevs.EQ.1) then
1850	print *,'Lecture du guidage sur niveaux mod�le'
1851	rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl)
1852	IF (rcode.NE.NF_NOERR) THEN
1853	print *,'Guide: probleme -> pas de fichier apbp.nc'
1854	CALL abort_gcm(modname,abort_message,1)
1855	ENDIF
1856	rcode = nf90_inq_varid(ncidpl, 'AP', varidap)
1857	IF (rcode.NE.NF_NOERR) THEN
1858	print *,'Guide: probleme -> pas de variable AP, fichier apbp.nc'
1859	CALL abort_gcm(modname,abort_message,1)
1860	ENDIF
1861	rcode = nf90_inq_varid(ncidpl, 'BP', varidbp)
1862	IF (rcode.NE.NF_NOERR) THEN
1863	print *,'Guide: probleme -> pas de variable BP, fichier apbp.nc'
1864	CALL abort_gcm(modname,abort_message,1)
1865	ENDIF
1866	print*,'ncidpl,varidap',ncidpl,varidap
1867	endif
1868	! Pression
1869	if (guide_plevs.EQ.2) then
1870	rcode = nf90_open('P.nc', nf90_nowrite, ncidp)
1871	IF (rcode.NE.NF_NOERR) THEN
1872	print *,'Guide: probleme -> pas de fichier P.nc'
1873	CALL abort_gcm(modname,abort_message,1)
1874	ENDIF
1875	rcode = nf90_inq_varid(ncidp, 'PRES', varidp)
1876	IF (rcode.NE.NF_NOERR) THEN
1877	print *,'Guide: probleme -> pas de variable PRES, fichier P.nc'
1878	CALL abort_gcm(modname,abort_message,1)
1879	ENDIF
1880	print*,'ncidp,varidp',ncidp,varidp
1881	if (ncidpl.eq.-99) ncidpl=ncidp
1882	endif
1883	! Vent zonal
1884	if (guide_u) then
1885	rcode = nf90_open('u.nc', nf90_nowrite, ncidu)
1886	IF (rcode.NE.NF_NOERR) THEN
1887	print *,'Guide: probleme -> pas de fichier u.nc'
1888	CALL abort_gcm(modname,abort_message,1)
1889	ENDIF
1890	rcode = nf90_inq_varid(ncidu, 'UWND', varidu)
1891	IF (rcode.NE.NF_NOERR) THEN
1892	print *,'Guide: probleme -> pas de variable UWND, fichier u.nc'
1893	CALL abort_gcm(modname,abort_message,1)
1894	ENDIF
1895	print*,'ncidu,varidu',ncidu,varidu
1896	if (ncidpl.eq.-99) ncidpl=ncidu
1897	endif
1898
1899	! Vent meridien
1900	if (guide_v) then
1901	rcode = nf90_open('v.nc', nf90_nowrite, ncidv)
1902	IF (rcode.NE.NF_NOERR) THEN
1903	print *,'Guide: probleme -> pas de fichier v.nc'
1904	CALL abort_gcm(modname,abort_message,1)
1905	ENDIF
1906	rcode = nf90_inq_varid(ncidv, 'VWND', varidv)
1907	IF (rcode.NE.NF_NOERR) THEN
1908	print *,'Guide: probleme -> pas de variable VWND, fichier v.nc'
1909	CALL abort_gcm(modname,abort_message,1)
1910	ENDIF
1911	print*,'ncidv,varidv',ncidv,varidv
1912	if (ncidpl.eq.-99) ncidpl=ncidv
1913	endif
1914	! Temperature
1915	if (guide_T) then
1916	rcode = nf90_open('T.nc', nf90_nowrite, ncidt)
1917	IF (rcode.NE.NF_NOERR) THEN
1918	print *,'Guide: probleme -> pas de fichier T.nc'
1919	CALL abort_gcm(modname,abort_message,1)
1920	ENDIF
1921	rcode = nf90_inq_varid(ncidt, 'AIR', varidt)
1922	IF (rcode.NE.NF_NOERR) THEN
1923	print *,'Guide: probleme -> pas de variable AIR, fichier T.nc'
1924	CALL abort_gcm(modname,abort_message,1)
1925	ENDIF
1926	print*,'ncidT,varidT',ncidt,varidt
1927	if (ncidpl.eq.-99) ncidpl=ncidt
1928	endif
1929	! Humidite
1930	if (guide_Q) then
1931	rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ)
1932	IF (rcode.NE.NF_NOERR) THEN
1933	print *,'Guide: probleme -> pas de fichier hur.nc'
1934	CALL abort_gcm(modname,abort_message,1)
1935	ENDIF
1936	rcode = nf90_inq_varid(ncidQ, 'RH', varidQ)
1937	IF (rcode.NE.NF_NOERR) THEN
1938	print *,'Guide: probleme -> pas de variable RH, fichier hur.nc'
1939	CALL abort_gcm(modname,abort_message,1)
1940	ENDIF
1941	print*,'ncidQ,varidQ',ncidQ,varidQ
1942	if (ncidpl.eq.-99) ncidpl=ncidQ
1943	endif
1944	! Pression de surface
1945	if ((guide_P).OR.(guide_plevs.EQ.1)) then
1946	rcode = nf90_open('ps.nc', nf90_nowrite, ncidps)
1947	IF (rcode.NE.NF_NOERR) THEN
1948	print *,'Guide: probleme -> pas de fichier ps.nc'
1949	CALL abort_gcm(modname,abort_message,1)
1950	ENDIF
1951	rcode = nf90_inq_varid(ncidps, 'SP', varidps)
1952	IF (rcode.NE.NF_NOERR) THEN
1953	print *,'Guide: probleme -> pas de variable SP, fichier ps.nc'
1954	CALL abort_gcm(modname,abort_message,1)
1955	ENDIF
1956	print*,'ncidps,varidps',ncidps,varidps
1957	endif
1958	! Coordonnee verticale
1959	if (guide_plevs.EQ.0) then
1960	rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl)
1961	IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl)
1962	print*,'ncidpl,varidpl',ncidpl,varidpl
1963	endif
1964	! Coefs ap, bp pour calcul de la pression aux differents niveaux
1965	if (guide_plevs.EQ.1) then
1966	#ifdef NC_DOUBLE
1967	status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc)
1968	status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc)
1969	#else
1970	status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc)
1971	status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc)
1972	#endif
1973	elseif (guide_plevs.EQ.0) THEN
1974	#ifdef NC_DOUBLE
1975	status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc)
1976	#else
1977	status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc)
1978	#endif
1979	apnc=apnc*100.! conversion en Pascals
1980	bpnc(:)=0.
1981	endif
1982	first=.FALSE.
1983	endif ! (first)
1984
1985	! -----------------------------------------------------------------
1986	! lecture des champs u, v, T, Q, ps
1987	! -----------------------------------------------------------------
1988
1989	! dimensions pour les champs scalaires et le vent zonal
1990	start(1)=1
1991	start(2)=jjb_u
1992	start(3)=1
1993	start(4)=timestep
1994
1995	count(1)=1
1996	count(2)=jjnb_u
1997	count(3)=nlevnc
1998	count(4)=1
1999
2000	IF (invert_y) start(2)=jjp1-jje_u+1
2001	! Pression
2002	if (guide_plevs.EQ.2) then
2003	#ifdef NC_DOUBLE
2004	status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu)
2005	#else
2006	status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu)
2007	#endif
2008	DO i=1,iip1
2009	pnat2(i,:,:)=zu(:,:)
2010	ENDDO
2011
2012	IF (invert_y) THEN
2013	! PRINT*,"Invertion impossible actuellement"
2014	! CALL abort_gcm(modname,abort_message,1)
2015	CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2)
2016	ENDIF
2017	endif
2018	! Vent zonal
2019	if (guide_u) then
2020	#ifdef NC_DOUBLE
2021	status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu)
2022	#else
2023	status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu)
2024	#endif
2025	DO i=1,iip1
2026	unat2(i,:,:)=zu(:,:)
2027	ENDDO
2028
2029	IF (invert_y) THEN
2030	! PRINT*,"Invertion impossible actuellement"
2031	! CALL abort_gcm(modname,abort_message,1)
2032	CALL invert_lat(iip1,jjnb_u,nlevnc,unat2)
2033	ENDIF
2034	endif
2035
2036
2037	! Temperature
2038	if (guide_T) then
2039	#ifdef NC_DOUBLE
2040	status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu)
2041	#else
2042	status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu)
2043	#endif
2044	DO i=1,iip1
2045	tnat2(i,:,:)=zu(:,:)
2046	ENDDO
2047
2048	IF (invert_y) THEN
2049	! PRINT*,"Invertion impossible actuellement"
2050	! CALL abort_gcm(modname,abort_message,1)
2051	CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2)
2052	ENDIF
2053	endif
2054
2055	! Humidite
2056	if (guide_Q) then
2057	#ifdef NC_DOUBLE
2058	status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu)
2059	#else
2060	status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu)
2061	#endif
2062	DO i=1,iip1
2063	qnat2(i,:,:)=zu(:,:)
2064	ENDDO
2065
2066	IF (invert_y) THEN
2067	! PRINT*,"Invertion impossible actuellement"
2068	! CALL abort_gcm(modname,abort_message,1)
2069	CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2)
2070	ENDIF
2071	endif
2072
2073	! Vent meridien
2074	if (guide_v) then
2075	start(2)=jjb_v
2076	count(2)=jjnb_v
2077	IF (invert_y) start(2)=jjm-jje_v+1
2078	#ifdef NC_DOUBLE
2079	status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv)
2080	#else
2081	status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv)
2082	#endif
2083	DO i=1,iip1
2084	vnat2(i,:,:)=zv(:,:)
2085	ENDDO
2086
2087	IF (invert_y) THEN
2088
2089	! PRINT*,"Invertion impossible actuellement"
2090	! CALL abort_gcm(modname,abort_message,1)
2091	CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2)
2092	ENDIF
2093	endif
2094
2095	! Pression de surface
2096	if ((guide_P).OR.(guide_plevs.EQ.1)) then
2097	start(2)=jjb_u
2098	start(3)=timestep
2099	start(4)=0
2100	count(2)=jjnb_u
2101	count(3)=1
2102	count(4)=0
2103	IF (invert_y) start(2)=jjp1-jje_u+1
2104	#ifdef NC_DOUBLE
2105	status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1))
2106	#else
2107	status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1))
2108	#endif
2109	DO i=1,iip1
2110	psnat2(i,:)=zu(:,1)
2111	ENDDO
2112
2113	IF (invert_y) THEN
2114	! PRINT*,"Invertion impossible actuellement"
2115	! CALL abort_gcm(modname,abort_message,1)
2116	CALL invert_lat(iip1,jjnb_u,1,psnat2)
2117	ENDIF
2118	endif
2119
2120	END SUBROUTINE guide_read2D
2121
2122	!=======================================================================
2123	SUBROUTINE guide_out(varname,hsize,vsize,field_loc,factt)
2124	USE parallel_lmdz
2125	USE mod_hallo, ONLY : gather_field_u, gather_field_v
2126	IMPLICIT NONE
2127
2128	INCLUDE "dimensions.h"
2129	INCLUDE "paramet.h"
2130	INCLUDE "netcdf.inc"
2131	INCLUDE "comgeom2.h"
2132	INCLUDE "comconst.h"
2133	INCLUDE "comvert.h"
2134
2135	! Variables entree
2136	CHARACTER(), INTENT(IN) :: varname
2137	INTEGER, INTENT (IN) :: hsize,vsize
2138	! REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field_loc
2139	REAL, DIMENSION (:,:), INTENT(IN) :: field_loc
2140	REAL factt
2141
2142	! Variables locales
2143	INTEGER, SAVE :: timestep=0
2144	! Identites fichier netcdf
2145	INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev
2146	INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev
2147	INTEGER :: vid_au,vid_av
2148	INTEGER, DIMENSION (3) :: dim3
2149	INTEGER, DIMENSION (4) :: dim4,count,start
2150	INTEGER :: ierr, varid,l
2151	REAL zu(ip1jmp1),zv(ip1jm)
2152	REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: field_glo
2153
2154	!$OMP MASTER
2155	ALLOCATE(field_glo(iip1,hsize,vsize))
2156	!$OMP END MASTER
2157	!$OMP BARRIER
2158
2159	print*,'gvide_out apres allocation ',hsize,vsize
2160
2161	IF (hsize==jjp1) THEN
2162	CALL gather_field_u(field_loc,field_glo,vsize)
2163	ELSE IF (hsize==jjm) THEN
2164	CALL gather_field_v(field_loc,field_glo, vsize)
2165	ENDIF
2166
2167	print*,'guide_out apres gather '
2168	CALL Gather_field_u(alpha_u,zu,1)
2169	CALL Gather_field_v(alpha_v,zv,1)
2170
2171	IF (mpi_rank > 0) THEN
2172	!$OMP MASTER
2173	DEALLOCATE(field_glo)
2174	!$OMP END MASTER
2175	!$OMP BARRIER
2176
2177	RETURN
2178	ENDIF
2179
2180	!$OMP MASTER
2181	IF (timestep.EQ.0) THEN
2182	! ----------------------------------------------
2183	! initialisation fichier de sortie
2184	! ----------------------------------------------
2185	! Ouverture du fichier
2186	ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid)
2187	! Definition des dimensions
2188	ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu)
2189	ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv)
2190	ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu)
2191	ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv)
2192	ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev)
2193	ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim)
2194
2195	! Creation des variables dimensions
2196	ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu)
2197	ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv)
2198	ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu)
2199	ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv)
2200	ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev)
2201	ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu)
2202	ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv)
2203	ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au)
2204	ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av)
2205
2206	ierr=NF_ENDDEF(nid)
2207
2208	! Enregistrement des variables dimensions
2209	#ifdef NC_DOUBLE
2210	ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi)
2211	ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi)
2212	ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi)
2213	ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi)
2214	ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs)
2215	ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu)
2216	ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv)
2217	ierr = NF_PUT_VAR_DOUBLE(nid,vid_au,zu)
2218	ierr = NF_PUT_VAR_DOUBLE(nid,vid_av,zv)
2219	#else
2220	ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi)
2221	ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi)
2222	ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi)
2223	ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi)
2224	ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs)
2225	ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu)
2226	ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv)
2227	ierr = NF_PUT_VAR_REAL(nid,vid_au,alpha_u)
2228	ierr = NF_PUT_VAR_REAL(nid,vid_av,alpha_v)
2229	#endif
2230	! --------------------------------------------------------------------
2231	! Cr�ation des variables sauvegard�es
2232	! --------------------------------------------------------------------
2233	ierr = NF_REDEF(nid)
2234	! Pressure (GCM)
2235	dim4=(/id_lonv,id_latu,id_lev,id_tim/)
2236	ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid)
2237	! Surface pressure (guidage)
2238	IF (guide_P) THEN
2239	dim3=(/id_lonv,id_latu,id_tim/)
2240	ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid)
2241	ENDIF
2242	! Zonal wind
2243	IF (guide_u) THEN
2244	dim4=(/id_lonu,id_latu,id_lev,id_tim/)
2245	ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid)
2246	ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid)
2247	ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid)
2248	ENDIF
2249	! Merid. wind
2250	IF (guide_v) THEN
2251	dim4=(/id_lonv,id_latv,id_lev,id_tim/)
2252	ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid)
2253	ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid)
2254	ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid)
2255	ENDIF
2256	! Pot. Temperature
2257	IF (guide_T) THEN
2258	dim4=(/id_lonv,id_latu,id_lev,id_tim/)
2259	ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid)
2260	ENDIF
2261	! Specific Humidity
2262	IF (guide_Q) THEN
2263	dim4=(/id_lonv,id_latu,id_lev,id_tim/)
2264	ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid)
2265	ENDIF
2266
2267	ierr = NF_ENDDEF(nid)
2268	ierr = NF_CLOSE(nid)
2269	ENDIF ! timestep=0
2270
2271	! --------------------------------------------------------------------
2272	! Enregistrement du champ
2273	! --------------------------------------------------------------------
2274
2275	ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid)
2276
2277	IF (varname=="SP") timestep=timestep+1
2278
2279	ierr = NF_INQ_VARID(nid,varname,varid)
2280	SELECT CASE (varname)
2281	CASE ("SP","ps")
2282	start=(/1,1,1,timestep/)
2283	count=(/iip1,jjp1,llm,1/)
2284	CASE ("v","va","vcov")
2285	start=(/1,1,1,timestep/)
2286	count=(/iip1,jjm,llm,1/)
2287	CASE DEFAULT
2288	start=(/1,1,1,timestep/)
2289	count=(/iip1,jjp1,llm,1/)
2290	END SELECT
2291
2292	!$OMP END MASTER
2293	!$OMP BARRIER
2294
2295	SELECT CASE (varname)
2296
2297	CASE("u","ua")
2298	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
2299	DO l=1,llm
2300	field_glo(:,2:jjm,l)=field_glo(:,2:jjm,l)/cu(:,2:jjm)
2301	field_glo(:,1,l)=0. ; field_glo(:,jjp1,l)=0.
2302	ENDDO
2303	CASE("v","va")
2304	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
2305	DO l=1,llm
2306	field_glo(:,:,l)=field_glo(:,:,l)/cv(:,:)
2307	ENDDO
2308	END SELECT
2309
2310	! if (varname=="ua") then
2311	! call dump2d(iip1,jjp1,field_glo,'ua gui1 1ere couche ')
2312	! call dump2d(iip1,jjp1,field_glo(:,:,llm),'ua gui1 llm ')
2313	! endif
2314
2315	!$OMP MASTER
2316
2317	#ifdef NC_DOUBLE
2318	ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field_glo)
2319	#else
2320	ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field_glo)
2321	#endif
2322
2323	ierr = NF_CLOSE(nid)
2324
2325	DEALLOCATE(field_glo)
2326	!$OMP END MASTER
2327	!$OMP BARRIER
2328
2329	RETURN
2330
2331	END SUBROUTINE guide_out
2332
2333
2334	!===========================================================================
2335	subroutine correctbid(iim,nl,x)
2336	integer iim,nl
2337	real x(iim+1,nl)
2338	integer i,l
2339	real zz
2340
2341	do l=1,nl
2342	do i=2,iim-1
2343	if(abs(x(i,l)).gt.1.e10) then
2344	zz=0.5*(x(i-1,l)+x(i+1,l))
2345	print*,'correction ',i,l,x(i,l),zz
2346	x(i,l)=zz
2347	endif
2348	enddo
2349	enddo
2350	return
2351	end subroutine correctbid
2352
2353
2354	!====================================================================
2355	! Ascii debug output. Could be reactivated
2356	!====================================================================
2357
2358	subroutine dump2du(var,varname)
2359	use parallel_lmdz
2360	use mod_hallo
2361	implicit none
2362	include 'dimensions.h'
2363	include 'paramet.h'
2364
2365	CHARACTER (len=*) :: varname
2366
2367
2368	real, dimension(ijb_u:ije_u) :: var
2369
2370	real, dimension(ip1jmp1) :: var_glob
2371
2372	RETURN
2373
2374	call barrier
2375	CALL Gather_field_u(var,var_glob,1)
2376	call barrier
2377
2378	if (mpi_rank==0) then
2379	call dump2d(iip1,jjp1,var_glob,varname)
2380	endif
2381
2382	call barrier
2383
2384	return
2385	end subroutine dump2du
2386
2387	!====================================================================
2388	! Ascii debug output. Could be reactivated
2389	!====================================================================
2390	subroutine dumpall
2391	implicit none
2392	include "dimensions.h"
2393	include "paramet.h"
2394	include "comgeom.h"
2395	call barrier
2396	call dump2du(alpha_u(ijb_u:ije_u),' alpha_u couche 1')
2397	call dump2du(unat2(:,jjbu:jjeu,nlevnc),' unat2 couche nlevnc')
2398	call dump2du(ugui1(ijb_u:ije_u,1)*sqrt(unscu2(ijb_u:ije_u)),' ugui1 couche 1')
2399	return
2400	end subroutine dumpall
2401
2402	!===========================================================================
2403	END MODULE guide_loc_mod

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

Download in other formats:

Original Format