Context Navigation

call_calfis_mod.F90 @ 1669

Last change on this file since 1669 was 1669, checked in by Laurent Fairhead, 12 years ago

Version testing basée sur la r1668

http://lmdz.lmd.jussieu.fr/utilisateurs/distribution-du-modele/versions-intermediaires

Testing release based on r1668

File size: 10.7 KB

Line
1	!#define DEBUG_IO
2	MODULE call_calfis_mod
3
4	REAL,POINTER,SAVE :: ucov(:,:)
5	REAL,POINTER,SAVE :: vcov(:,:)
6	REAL,POINTER,SAVE :: teta(:,:)
7	REAL,POINTER,SAVE :: masse(:,:)
8	REAL,POINTER,SAVE :: ps(:)
9	REAL,POINTER,SAVE :: phis(:)
10	REAL,POINTER,SAVE :: q(:,:,:)
11	REAL,POINTER,SAVE :: flxw(:,:)
12
13	REAL,POINTER,SAVE :: p(:,:)
14	REAL,POINTER,SAVE :: alpha(:,:)
15	REAL,POINTER,SAVE :: beta(:,:)
16	REAL,POINTER,SAVE :: pks(:)
17	REAL,POINTER,SAVE :: pk(:,:)
18	REAL,POINTER,SAVE :: pkf(:,:)
19	REAL,POINTER,SAVE :: phi(:,:)
20	REAL,POINTER,SAVE :: du(:,:)
21	REAL,POINTER,SAVE :: dv(:,:)
22	REAL,POINTER,SAVE :: dteta(:,:)
23	REAL,POINTER,SAVE :: dq(:,:,:)
24	REAL,POINTER,SAVE :: dufi(:,:)
25	REAL,POINTER,SAVE :: dvfi(:,:)
26	REAL,POINTER,SAVE :: dtetafi(:,:)
27	REAL,POINTER,SAVE :: dqfi(:,:,:)
28	REAL,POINTER,SAVE :: dpfi(:)
29
30
31
32
33
34	CONTAINS
35
36	SUBROUTINE call_calfis_allocate
37	USE bands
38	USE allocate_field
39	USE parallel
40	USE dimensions
41	USE infotrac
42	IMPLICIT NONE
43	TYPE(distrib),POINTER :: d
44	d=>distrib_physic
45
46	CALL allocate_u(ucov,llm,d)
47	CALL allocate_v(vcov,llm,d)
48	CALL allocate_u(teta,llm,d)
49	CALL allocate_u(masse,llm,d)
50	CALL allocate_u(ps,d)
51	CALL allocate_u(phis,d)
52	CALL allocate_u(q,llm,nqtot,d)
53	CALL allocate_u(flxw,llm,d)
54	CALL allocate_u(p,llmp1,d)
55	CALL allocate_u(alpha,llm,d)
56	CALL allocate_u(beta,llm,d)
57	CALL allocate_u(pks,d)
58	CALL allocate_u(pk,llm,d)
59	CALL allocate_u(pkf,llm,d)
60	CALL allocate_u(phi,llm,d)
61	CALL allocate_u(du,llm,d)
62	CALL allocate_v(dv,llm,d)
63	CALL allocate_u(dteta,llm,d)
64	CALL allocate_u(dq,llm,nqtot,d)
65	CALL allocate_u(dufi,llm,d)
66	CALL allocate_v(dvfi,llm,d)
67	CALL allocate_u(dtetafi,llm,d)
68	CALL allocate_u(dqfi,llm,nqtot,d)
69	CALL allocate_u(dpfi,d)
70
71	END SUBROUTINE call_calfis_allocate
72
73
74	SUBROUTINE call_calfis(itau,lafin,clesphy0,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
75	phis_dyn,q_dyn,flxw_dyn)
76	USE dimensions
77	USE parallel
78	USE times
79	USE mod_hallo
80	USE Bands
81	USE vampir
82	USE infotrac
83	USE control_mod
84	USE write_field_loc
85	USE write_field
86	IMPLICIT NONE
87	INCLUDE "comconst.h"
88	INCLUDE "comvert.h"
89	INCLUDE "logic.h"
90	INCLUDE "temps.h"
91	INCLUDE "iniprint.h"
92
93	REAL :: clesphy0( : )
94	INTEGER :: itau
95	LOGICAL :: lafin
96	REAL :: ucov_dyn(ijb_u:ije_u,llm)
97	REAL :: vcov_dyn(ijb_v:ije_v,llm)
98	REAL :: teta_dyn(ijb_u:ije_u,llm)
99	REAL :: masse_dyn(ijb_u:ije_u,llm)
100	REAL :: ps_dyn(ijb_u:ije_u)
101	REAL :: phis_dyn(ijb_u:ije_u)
102	REAL :: q_dyn(ijb_u:ije_u,llm,nqtot)
103	REAL :: flxw_dyn(ijb_u:ije_u,llm)
104
105	REAL :: dufi_tmp(iip1,llm)
106	REAL :: dvfi_tmp(iip1,llm)
107	REAL :: dtetafi_tmp(iip1,llm)
108	REAL :: dpfi_tmp(iip1)
109	REAL :: dqfi_tmp(iip1,llm,nqtot)
110
111	REAL :: jD_cur, jH_cur
112	CHARACTER(LEN=15) :: ztit
113	TYPE(Request) :: Request_physic
114	INTEGER :: ijb,ije,l,j
115
116
117	#ifdef DEBUG_IO
118	CALL WriteField_u('ucovfi',ucov)
119	CALL WriteField_v('vcovfi',vcov)
120	CALL WriteField_u('tetafi',teta)
121	CALL WriteField_u('pfi',p)
122	CALL WriteField_u('pkfi',pk)
123	DO j=1,nqtot
124	CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
125	ENDDO
126	#endif
127
128	!
129	! ....... Ajout P.Le Van ( 17/04/96 ) ...........
130	!
131
132
133	!$OMP MASTER
134	CALL suspend_timer(timer_caldyn)
135	WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
136	!$OMP END MASTER
137
138	jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec)
139	jH_cur = jH_ref + (itau * dtvr / daysec - int(itau * dtvr / daysec))
140
141	! Inbterface avec les routines de phylmd (phymars ... )
142	! -----------------------------------------------------
143
144	!+jld
145
146	! Diagnostique de conservation de l'energie : initialisation
147
148	!-jld
149	!$OMP BARRIER
150	!$OMP MASTER
151	CALL VTb(VThallo)
152	!$OMP END MASTER
153
154	#ifdef DEBUG_IO
155	CALL WriteField_u('ucovfi',ucov)
156	CALL WriteField_v('vcovfi',vcov)
157	CALL WriteField_u('tetafi',teta)
158	CALL WriteField_u('pfi',p)
159	CALL WriteField_u('pkfi',pk)
160	#endif
161
162	CALL SetTag(Request_physic,800)
163	CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
164	CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
165	CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
166	CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
167	CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
168	CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
169	CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
170	CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
171
172	CALL SendRequest(Request_Physic)
173	!$OMP BARRIER
174	CALL WaitRequest(Request_Physic)
175
176	!$OMP BARRIER
177	!$OMP MASTER
178	CALL Set_Distrib(distrib_Physic)
179	CALL VTe(VThallo)
180
181	CALL VTb(VTphysiq)
182	!$OMP END MASTER
183	!$OMP BARRIER
184
185	CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
186
187	!$OMP BARRIER
188	CALL exner_hyb_loc( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
189	!$OMP BARRIER
190	CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi )
191
192
193	CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
194	CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
195	CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
196
197	CALL SendRequest(Request_Physic)
198	!$OMP BARRIER
199	CALL WaitRequest(Request_Physic)
200
201	!$OMP BARRIER
202
203
204	#ifdef DEBUG_IO
205	CALL WriteField_u('ucovfi',ucov)
206	CALL WriteField_v('vcovfi',vcov)
207	CALL WriteField_u('tetafi',teta)
208	CALL WriteField_u('pfi',p)
209	CALL WriteField_u('pkfi',pk)
210	DO j=1,nqtot
211	CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
212	ENDDO
213	#endif
214
215	!$OMP BARRIER
216
217	CALL calfis_loc(lafin ,jD_cur, jH_cur, &
218	ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , &
219	du,dv,dteta,dq, &
220	flxw, &
221	clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi )
222
223	ijb=ij_begin
224	ije=ij_end
225	IF ( .not. pole_nord) THEN
226
227	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
228	DO l=1,llm
229	dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l)
230	dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l)
231	dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l)
232	dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:)
233	ENDDO
234	!$OMP END DO NOWAIT
235
236	!$OMP MASTER
237	dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim)
238	!$OMP END MASTER
239
240	ENDIF ! of if ( .not. pole_nord)
241
242	!$OMP BARRIER
243	!$OMP MASTER
244	CALL Set_Distrib(distrib_Physic_bis)
245	CALL VTb(VThallo)
246	!$OMP END MASTER
247	!$OMP BARRIER
248
249	CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
250	CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
251	CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
252	CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
253
254	DO j=1,nqtot
255	CALL Register_Hallo_u(dqfi(:,:,j),llm,1,0,0,1,Request_physic)
256	ENDDO
257
258	CALL SendRequest(Request_Physic)
259	!$OMP BARRIER
260	CALL WaitRequest(Request_Physic)
261
262	!$OMP BARRIER
263	!$OMP MASTER
264	CALL VTe(VThallo)
265	CALL Set_Distrib(distrib_Physic)
266	!$OMP END MASTER
267	!$OMP BARRIER
268	ijb=ij_begin
269	IF (.not. pole_nord) THEN
270
271	!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
272	DO l=1,llm
273	dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
274	dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
275	dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
276	dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
277	ENDDO
278	!$OMP END DO NOWAIT
279
280	!$OMP MASTER
281	dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
282	!$OMP END MASTER
283
284	endif ! of if (.not. pole_nord)
285
286
287	#ifdef DEBUG_IO
288	CALL WriteField_u('dufi',dufi)
289	CALL WriteField_v('dvfi',dvfi)
290	CALL WriteField_u('dtetafi',dtetafi)
291	CALL WriteField_u('dpfi',dpfi)
292	DO j=1,nqtot
293	CALL WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
294	ENDDO
295	#endif
296
297	!$OMP BARRIER
298
299	! ajout des tendances physiques:
300	! ------------------------------
301	#ifdef DEBUG_IO
302	CALL WriteField_u('ucovfi',ucov)
303	CALL WriteField_v('vcovfi',vcov)
304	CALL WriteField_u('tetafi',teta)
305	CALL WriteField_u('psfi',ps)
306	DO j=1,nqtot
307	CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
308	ENDDO
309	#endif
310
311	IF (ok_strato) THEN
312	CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
313	ENDIF
314
315	#ifdef DEBUG_IO
316	CALL WriteField_u('ucovfi',ucov)
317	CALL WriteField_v('vcovfi',vcov)
318	CALL WriteField_u('tetafi',teta)
319	CALL WriteField_u('psfi',ps)
320	DO j=1,nqtot
321	CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
322	ENDDO
323	#endif
324
325	CALL addfi_loc( dtphys, leapf, forward , &
326	ucov, vcov, teta , q ,ps , &
327	dufi, dvfi, dtetafi , dqfi ,dpfi )
328
329	#ifdef DEBUG_IO
330	CALL WriteField_u('ucovfi',ucov)
331	CALL WriteField_v('vcovfi',vcov)
332	CALL WriteField_u('tetafi',teta)
333	CALL WriteField_u('psfi',ps)
334	DO j=1,nqtot
335	CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
336	ENDDO
337	#endif
338
339	!$OMP BARRIER
340	!$OMP MASTER
341	CALL VTe(VTphysiq)
342	CALL VTb(VThallo)
343	!$OMP END MASTER
344
345	CALL SetTag(Request_physic,800)
346	CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
347	CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
348	CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
349	CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
350	CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
351	CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
352	CALL SendRequest(Request_Physic)
353	!$OMP BARRIER
354	CALL WaitRequest(Request_Physic)
355
356	!$OMP BARRIER
357	!$OMP MASTER
358	CALL VTe(VThallo)
359	CALL set_distrib(distrib_caldyn)
360	!$OMP END MASTER
361	!$OMP BARRIER
362
363	!
364	! Diagnostique de conservation de l'energie : difference
365	IF (ip_ebil_dyn.ge.1 ) THEN
366	ztit='bil phys'
367	CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
368	ENDIF
369
370	#ifdef DEBUG_IO
371	CALL WriteField_u('ucovfi',ucov_dyn)
372	CALL WriteField_v('vcovfi',vcov_dyn)
373	CALL WriteField_u('tetafi',teta_dyn)
374	CALL WriteField_u('psfi',ps_dyn)
375	DO j=1,nqtot
376	CALL WriteField_u('qfi'//trim(int2str(j)),q_dyn(:,:,j))
377	ENDDO
378	#endif
379
380
381	!-jld
382	!$OMP MASTER
383	CALL resume_timer(timer_caldyn)
384	!$OMP END MASTER
385
386	END SUBROUTINE call_calfis
387
388	END MODULE call_calfis_mod

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

Download in other formats:

Original Format