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

Last change on this file since 1795 was 1795, checked in by Ehouarn Millour, 11 years ago

Version testing basee sur la r1794

Testing release based on r1794
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#ifdef DEBUG_IO           
324    CALL WriteField_u('ucovfi',ucov)
325    CALL WriteField_v('vcovfi',vcov)
326    CALL WriteField_u('tetafi',teta)
327    CALL WriteField_u('psfi',ps)
328    DO j=1,nqtot
329      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
330    ENDDO
331#endif
332
333    CALL addfi_loc( dtphys, leapf, forward   ,              &
334                    ucov, vcov, teta , q   ,ps ,            &
335                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
336
337#ifdef DEBUG_IO   
338    CALL WriteField_u('ucovfi',ucov)
339    CALL WriteField_v('vcovfi',vcov)
340    CALL WriteField_u('tetafi',teta)
341    CALL WriteField_u('psfi',ps)
342    DO j=1,nqtot
343      CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j))
344    ENDDO
345#endif
346
347    IF (ok_strato) THEN
348!      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
349      CALL top_bound_loc(vcov,ucov,teta,masse,dtphys)
350    ENDIF
351
352  !$OMP BARRIER
353  !$OMP MASTER
354    CALL VTe(VTphysiq)
355    CALL VTb(VThallo)
356  !$OMP END MASTER
357
358    CALL SetTag(Request_physic,800)
359    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
360    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
361    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
362    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
363    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
364    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
365    CALL SendRequest(Request_Physic)
366  !$OMP BARRIER
367    CALL WaitRequest(Request_Physic)     
368
369  !$OMP BARRIER
370  !$OMP MASTER
371    CALL VTe(VThallo)
372    CALL set_distrib(distrib_caldyn)
373  !$OMP END MASTER
374  !$OMP BARRIER
375
376!
377!  Diagnostique de conservation de l'energie : difference
378    IF (ip_ebil_dyn.ge.1 ) THEN
379      ztit='bil phys'
380      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
381    ENDIF
382
383#ifdef DEBUG_IO   
384    CALL WriteField_u('ucovfi',ucov_dyn)
385    CALL WriteField_v('vcovfi',vcov_dyn)
386    CALL WriteField_u('tetafi',teta_dyn)
387    CALL WriteField_u('psfi',ps_dyn)
388    DO j=1,nqtot
389      CALL WriteField_u('qfi'//trim(int2str(j)),q_dyn(:,:,j))
390    ENDDO
391#endif
392
393
394!-jld
395    !$OMP MASTER
396      CALL resume_timer(timer_caldyn)
397    !$OMP END MASTER
398
399  END SUBROUTINE call_calfis
400 
401END MODULE call_calfis_mod
Note: See TracBrowser for help on using the repository browser.