source: LMDZ5/trunk/libf/call_calfis_mod.F90 @ 1630

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

Importation initiale du répertoire dyn3dmem

Initial import of dyn3dmem directory
File size: 10.7 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 + 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 
388END MODULE call_calfis_mod
Note: See TracBrowser for help on using the repository browser.