source: LMDZ5/branches/testing/libf/dyn3dmem/call_calfis_mod.F90 @ 1790

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

Version testing basée sur la r1706

Testing release based on r1706
File size: 11.1 KB
Line 
1!#define DEBUG_IO
2MODULE 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   
34CONTAINS
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                           &
139     &        + itau/day_step
140
141           IF (planet_type .eq."generic") THEN
142              ! AS: we make jD_cur to be pday
143              jD_cur = int(day_ini + itau/day_step)
144           ENDIF
145
146           jH_cur = jH_ref + start_time +                                &
147     &              mod(itau,day_step)/float(day_step)
148    if (jH_cur > 1.0 ) then
149      jD_cur = jD_cur +1.
150      jH_cur = jH_cur -1.
151    endif
152
153!   Inbterface avec les routines de phylmd (phymars ... )
154!   -----------------------------------------------------
155
156!+jld
157
158!  Diagnostique de conservation de l'energie : initialisation
159 
160!-jld
161  !$OMP BARRIER
162  !$OMP MASTER
163    CALL VTb(VThallo)
164  !$OMP END MASTER
165
166#ifdef DEBUG_IO   
167    CALL WriteField_u('ucovfi',ucov)
168    CALL WriteField_v('vcovfi',vcov)
169    CALL WriteField_u('tetafi',teta)
170    CALL WriteField_u('pfi',p)
171    CALL WriteField_u('pkfi',pk)
172#endif
173   
174    CALL SetTag(Request_physic,800)
175    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
176    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
177    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
178    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
179    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
180    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
181    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
182    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
183 
184    CALL SendRequest(Request_Physic)
185  !$OMP BARRIER
186    CALL WaitRequest(Request_Physic)       
187
188  !$OMP BARRIER
189  !$OMP MASTER
190    CALL Set_Distrib(distrib_Physic)
191    CALL VTe(VThallo)
192       
193    CALL VTb(VTphysiq)
194  !$OMP END MASTER
195  !$OMP BARRIER
196
197    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
198
199  !$OMP BARRIER
200    CALL exner_hyb_loc(  ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
201  !$OMP BARRIER
202    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
203
204
205    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
206    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
207    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
208       
209    CALL SendRequest(Request_Physic)
210  !$OMP BARRIER
211    CALL WaitRequest(Request_Physic)
212             
213  !$OMP BARRIER
214 
215 
216#ifdef DEBUG_IO   
217    CALL WriteField_u('ucovfi',ucov)
218    CALL WriteField_v('vcovfi',vcov)
219    CALL WriteField_u('tetafi',teta)
220    CALL WriteField_u('pfi',p)
221    CALL WriteField_u('pkfi',pk)
222    DO j=1,nqtot
223      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
224    ENDDO
225#endif
226
227  !$OMP BARRIER
228
229    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
230                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
231                     du,dv,dteta,dq,                             &
232                     flxw,                                       &
233                     clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi  )
234
235    ijb=ij_begin
236    ije=ij_end 
237    IF ( .not. pole_nord) THEN
238 
239    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
240      DO l=1,llm
241        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
242        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l) 
243        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) 
244        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) 
245      ENDDO
246    !$OMP END DO NOWAIT
247
248    !$OMP MASTER
249      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim) 
250    !$OMP END MASTER
251   
252    ENDIF ! of if ( .not. pole_nord)
253
254  !$OMP BARRIER
255  !$OMP MASTER
256    CALL Set_Distrib(distrib_Physic_bis)
257    CALL VTb(VThallo)
258  !$OMP END MASTER
259  !$OMP BARRIER
260 
261    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
262    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
263    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
264    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
265
266    DO j=1,nqtot
267      CALL Register_Hallo_u(dqfi(:,:,j),llm,1,0,0,1,Request_physic)
268    ENDDO
269       
270    CALL SendRequest(Request_Physic)
271  !$OMP BARRIER
272    CALL WaitRequest(Request_Physic)
273             
274  !$OMP BARRIER
275  !$OMP MASTER
276    CALL VTe(VThallo)
277    CALL Set_Distrib(distrib_Physic)
278  !$OMP END MASTER
279  !$OMP BARRIER       
280    ijb=ij_begin
281    IF (.not. pole_nord) THEN
282       
283    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
284      DO l=1,llm
285        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
286        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
287        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
288        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
289      ENDDO
290    !$OMP END DO NOWAIT
291
292    !$OMP MASTER
293      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
294    !$OMP END MASTER
295         
296    endif ! of if (.not. pole_nord)
297       
298       
299#ifdef DEBUG_IO           
300    CALL WriteField_u('dufi',dufi)
301    CALL WriteField_v('dvfi',dvfi)
302    CALL WriteField_u('dtetafi',dtetafi)
303    CALL WriteField_u('dpfi',dpfi)
304    DO j=1,nqtot
305      CALL WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j))
306    ENDDO
307#endif
308
309  !$OMP BARRIER
310
311!      ajout des tendances physiques:
312!      ------------------------------
313#ifdef DEBUG_IO   
314    CALL WriteField_u('ucovfi',ucov)
315    CALL WriteField_v('vcovfi',vcov)
316    CALL WriteField_u('tetafi',teta)
317    CALL WriteField_u('psfi',ps)
318    DO j=1,nqtot
319      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
320    ENDDO
321#endif
322
323    IF (ok_strato) THEN
324      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
325    ENDIF
326
327#ifdef DEBUG_IO           
328    CALL WriteField_u('ucovfi',ucov)
329    CALL WriteField_v('vcovfi',vcov)
330    CALL WriteField_u('tetafi',teta)
331    CALL WriteField_u('psfi',ps)
332    DO j=1,nqtot
333      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
334    ENDDO
335#endif
336
337    CALL addfi_loc( dtphys, leapf, forward   ,              &
338                    ucov, vcov, teta , q   ,ps ,            &
339                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
340
341#ifdef DEBUG_IO   
342    CALL WriteField_u('ucovfi',ucov)
343    CALL WriteField_v('vcovfi',vcov)
344    CALL WriteField_u('tetafi',teta)
345    CALL WriteField_u('psfi',ps)
346    DO j=1,nqtot
347      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
348    ENDDO
349#endif
350
351  !$OMP BARRIER
352  !$OMP MASTER
353    CALL VTe(VTphysiq)
354    CALL VTb(VThallo)
355  !$OMP END MASTER
356
357    CALL SetTag(Request_physic,800)
358    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
359    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
360    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
361    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
362    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
363    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
364    CALL SendRequest(Request_Physic)
365  !$OMP BARRIER
366    CALL WaitRequest(Request_Physic)     
367
368  !$OMP BARRIER
369  !$OMP MASTER
370    CALL VTe(VThallo)
371    CALL set_distrib(distrib_caldyn)
372  !$OMP END MASTER
373  !$OMP BARRIER
374
375!
376!  Diagnostique de conservation de l'energie : difference
377    IF (ip_ebil_dyn.ge.1 ) THEN
378      ztit='bil phys'
379      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
380    ENDIF
381
382#ifdef DEBUG_IO   
383    CALL WriteField_u('ucovfi',ucov_dyn)
384    CALL WriteField_v('vcovfi',vcov_dyn)
385    CALL WriteField_u('tetafi',teta_dyn)
386    CALL WriteField_u('psfi',ps_dyn)
387    DO j=1,nqtot
388      CALL WriteField_u('qfi'//trim(int2str(j)),q_dyn(:,:,j))
389    ENDDO
390#endif
391
392
393!-jld
394    !$OMP MASTER
395      CALL resume_timer(timer_caldyn)
396    !$OMP END MASTER
397
398  END SUBROUTINE call_calfis
399 
400END MODULE call_calfis_mod
Note: See TracBrowser for help on using the repository browser.