source: LMDZ5/trunk/libf/dyn3dmem/call_calfis_mod.F90 @ 1972

Last change on this file since 1972 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

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