source: LMDZ6/trunk/libf/dyn3dmem/call_calfis_mod.f90 @ 5278

Last change on this file since 5278 was 5272, checked in by abarral, 2 days ago

Turn paramet.h into a module
  • 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: 12.5 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 :: pks(:)
15    REAL,POINTER,SAVE :: pk(:,:)
16    REAL,POINTER,SAVE :: pkf(:,:)
17    REAL,POINTER,SAVE :: phi(:,:)
18    REAL,POINTER,SAVE :: du(:,:)
19    REAL,POINTER,SAVE :: dv(:,:)
20    REAL,POINTER,SAVE :: dteta(:,:)
21    REAL,POINTER,SAVE :: dq(:,:,:)
22    REAL,POINTER,SAVE :: dufi(:,:)
23    REAL,POINTER,SAVE :: dvfi(:,:)
24    REAL,POINTER,SAVE :: dtetafi(:,:)
25    REAL,POINTER,SAVE :: dqfi(:,:,:)
26    REAL,POINTER,SAVE :: dpfi(:)
27   
28   
29   
30   
31   
32CONTAINS
33
34  SUBROUTINE call_calfis_allocate
35  USE bands
36  USE allocate_field_mod
37  USE parallel_lmdz
38  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
39  USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
40          ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
41  USE infotrac, ONLY: nqtot
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(pks,d)
56    pks(:)=0
57    CALL allocate_u(pk,llm,d)
58    pk(:,:)=0
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,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
75                         phis_dyn,q_dyn,flxw_dyn)
76  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
77  USE paramet_mod_h, ONLY: iip1, iip2, iip3, jjp1, llmp1, llmp2, llmm1, kftd, ip1jm, ip1jmp1, &
78          ip1jmi1, ijp1llm, ijmllm, mvar, jcfil, jcfllm
79  USE exner_hyb_loc_m, only: exner_hyb_loc
80  use exner_milieu_loc_m, only: exner_milieu_loc
81  USE parallel_lmdz
82  USE times
83  USE mod_hallo
84  USE Bands
85  USE vampir
86  USE infotrac, ONLY: nqtot
87  USE control_mod
88  USE write_field_loc
89  USE write_field
90  USE comconst_mod, ONLY: dtphys
91  USE logic_mod, ONLY: leapf, forward, ok_strato
92  USE comvert_mod, ONLY: ap, bp, pressure_exner
93  USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time
94  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS, CPPKEY_DEBUGIO
95  USE strings_mod, ONLY: int2str
96 
97  IMPLICIT NONE
98    INCLUDE "iniprint.h"
99
100    INTEGER,INTENT(IN) :: itau ! (time) iteration step number
101    LOGICAL,INTENT(IN) :: lafin ! .true. if final time step
102    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
103    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
104    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature
105    REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass
106    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
107    REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential
108    REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers
109    REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux
110
111    REAL :: dufi_tmp(iip1,llm)   
112    REAL :: dvfi_tmp(iip1,llm) 
113    REAL :: dtetafi_tmp(iip1,llm)
114    REAL :: dpfi_tmp(iip1)
115    REAL :: dqfi_tmp(iip1,llm,nqtot)
116
117    REAL :: jD_cur, jH_cur
118    CHARACTER(LEN=15) :: ztit
119    TYPE(Request),SAVE :: Request_physic
120!$OMP THREADPRIVATE(Request_physic )
121    INTEGER :: ijb,ije,l,iq
122   
123   
124IF (CPPKEY_DEBUGIO) THEN
125    CALL WriteField_u('ucovfi',ucov)
126    CALL WriteField_v('vcovfi',vcov)
127    CALL WriteField_u('tetafi',teta)
128    CALL WriteField_u('pfi',p)
129    CALL WriteField_u('pkfi',pk)
130    DO iq=1,nqtot
131      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
132    ENDDO
133END IF
134
135!
136!     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
137!
138
139
140  !$OMP MASTER
141    CALL suspend_timer(timer_caldyn)
142    IF (prt_level >= 10) THEN
143      WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
144    ENDIF
145  !$OMP END MASTER
146   
147           jD_cur = jD_ref + day_ini - day_ref                           &
148     &        + (itau+1)/day_step
149
150           IF (planet_type .eq."generic") THEN
151              ! AS: we make jD_cur to be pday
152              jD_cur = int(day_ini + itau/day_step)
153           ENDIF
154
155           jH_cur = jH_ref + start_time +                                &
156     &              mod(itau+1,day_step)/float(day_step)
157    if (jH_cur > 1.0 ) then
158      jD_cur = jD_cur +1.
159      jH_cur = jH_cur -1.
160    endif
161
162!   Inbterface avec les routines de phylmd (phymars ... )
163!   -----------------------------------------------------
164
165!+jld
166
167!  Diagnostique de conservation de l'energie : initialisation
168 
169!-jld
170  !$OMP BARRIER
171  !$OMP MASTER
172    CALL VTb(VThallo)
173  !$OMP END MASTER
174
175IF (CPPKEY_DEBUGIO) THEN
176    CALL WriteField_u('ucovfi',ucov)
177    CALL WriteField_v('vcovfi',vcov)
178    CALL WriteField_u('tetafi',teta)
179    CALL WriteField_u('pfi',p)
180    CALL WriteField_u('pkfi',pk)
181END IF
182   
183    CALL SetTag(Request_physic,800)
184    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
185    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
186    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
187    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
188    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
189    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
190    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
191    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
192 
193    CALL SendRequest(Request_Physic)
194  !$OMP BARRIER
195    CALL WaitRequest(Request_Physic)       
196
197  !$OMP BARRIER
198  !$OMP MASTER
199    CALL Set_Distrib(distrib_Physic)
200    CALL VTe(VThallo)
201       
202    CALL VTb(VTphysiq)
203  !$OMP END MASTER
204  !$OMP BARRIER
205
206    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
207
208  !$OMP BARRIER
209    CALL exner_hyb_loc(  ip1jmp1, ps, p, pks, pk, pkf )
210  !$OMP BARRIER
211    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
212
213
214    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
215    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
216    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
217       
218    CALL SendRequest(Request_Physic)
219  !$OMP BARRIER
220    CALL WaitRequest(Request_Physic)
221             
222  !$OMP BARRIER
223 
224 
225IF (CPPKEY_DEBUGIO) THEN
226    CALL WriteField_u('ucovfi',ucov)
227    CALL WriteField_v('vcovfi',vcov)
228    CALL WriteField_u('tetafi',teta)
229    CALL WriteField_u('pfi',p)
230    CALL WriteField_u('pkfi',pk)
231    DO iq=1,nqtot
232      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
233    ENDDO
234END IF
235
236  !$OMP BARRIER
237
238IF (CPPKEY_PHYS) THEN
239    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
240                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
241                     du,dv,dteta,dq,                             &
242                     flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
243END IF
244    ijb=ij_begin
245    ije=ij_end 
246    IF ( .not. pole_nord) THEN
247 
248    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
249      DO l=1,llm
250        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
251        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l) 
252        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) 
253        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) 
254      ENDDO
255    !$OMP END DO NOWAIT
256
257    !$OMP MASTER
258      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim) 
259    !$OMP END MASTER
260   
261    ENDIF ! of if ( .not. pole_nord)
262
263  !$OMP BARRIER
264  !$OMP MASTER
265    CALL Set_Distrib(distrib_Physic_bis)
266    CALL VTb(VThallo)
267  !$OMP END MASTER
268  !$OMP BARRIER
269 
270    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
271    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
272    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
273    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
274
275    DO iq=1,nqtot
276      CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic)
277    ENDDO
278       
279    CALL SendRequest(Request_Physic)
280  !$OMP BARRIER
281    CALL WaitRequest(Request_Physic)
282             
283  !$OMP BARRIER
284  !$OMP MASTER
285    CALL VTe(VThallo)
286    CALL Set_Distrib(distrib_Physic)
287  !$OMP END MASTER
288  !$OMP BARRIER       
289    ijb=ij_begin
290    IF (.not. pole_nord) THEN
291       
292    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
293      DO l=1,llm
294        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
295        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
296        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
297        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
298      ENDDO
299    !$OMP END DO NOWAIT
300
301    !$OMP MASTER
302      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
303    !$OMP END MASTER
304         
305    endif ! of if (.not. pole_nord)
306       
307       
308IF (CPPKEY_DEBUGIO) THEN
309    CALL WriteField_u('dufi',dufi)
310    CALL WriteField_v('dvfi',dvfi)
311    CALL WriteField_u('dtetafi',dtetafi)
312    CALL WriteField_u('dpfi',dpfi)
313    DO iq=1,nqtot
314      CALL WriteField_u('dqfi'//trim(int2str(iq)),dqfi(:,:,iq))
315    ENDDO
316END IF
317
318  !$OMP BARRIER
319
320!      ajout des tendances physiques:
321!      ------------------------------
322IF (CPPKEY_DEBUGIO) THEN
323    CALL WriteField_u('ucovfi',ucov)
324    CALL WriteField_v('vcovfi',vcov)
325    CALL WriteField_u('tetafi',teta)
326    CALL WriteField_u('psfi',ps)
327    DO iq=1,nqtot
328      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
329    ENDDO
330END IF
331
332IF (CPPKEY_DEBUGIO) THEN
333    CALL WriteField_u('ucovfi',ucov)
334    CALL WriteField_v('vcovfi',vcov)
335    CALL WriteField_u('tetafi',teta)
336    CALL WriteField_u('psfi',ps)
337    DO iq=1,nqtot
338      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
339    ENDDO
340END IF
341
342    CALL addfi_loc( dtphys, leapf, forward   ,              &
343                    ucov, vcov, teta , q   ,ps ,            &
344                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
345    ! since addfi updates ps(), also update p(), masse() and pk()
346    CALL pression_loc(ip1jmp1,ap,bp,ps,p)
347!$OMP BARRIER
348    CALL massdair_loc(p,masse)
349!$OMP BARRIER
350    if (pressure_exner) then
351      CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf)
352    else
353      CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf)
354    endif
355!$OMP BARRIER
356
357IF (CPPKEY_DEBUGIO) THEN
358    CALL WriteField_u('ucovfi',ucov)
359    CALL WriteField_v('vcovfi',vcov)
360    CALL WriteField_u('tetafi',teta)
361    CALL WriteField_u('psfi',ps)
362    DO iq=1,nqtot
363      CALL WriteField_u('qfi'//trim(int2str(iq)),q(:,:,iq))
364    ENDDO
365END IF
366
367    IF (ok_strato) THEN
368!      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
369      CALL top_bound_loc(vcov,ucov,teta,masse,dtphys)
370    ENDIF
371
372  !$OMP BARRIER
373  !$OMP MASTER
374    CALL VTe(VTphysiq)
375    CALL VTb(VThallo)
376  !$OMP END MASTER
377
378    CALL SetTag(Request_physic,800)
379    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
380    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
381    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
382    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
383    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
384    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
385    CALL SendRequest(Request_Physic)
386  !$OMP BARRIER
387    CALL WaitRequest(Request_Physic)     
388
389  !$OMP BARRIER
390  !$OMP MASTER
391    CALL VTe(VThallo)
392    CALL set_distrib(distrib_caldyn)
393  !$OMP END MASTER
394  !$OMP BARRIER
395
396!
397!  Diagnostique de conservation de l'energie : difference
398    IF (ip_ebil_dyn.ge.1 ) THEN
399      ztit='bil phys'
400!      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
401      write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!"
402    ENDIF
403
404IF (CPPKEY_DEBUGIO) THEN
405    CALL WriteField_u('ucovfi',ucov_dyn)
406    CALL WriteField_v('vcovfi',vcov_dyn)
407    CALL WriteField_u('tetafi',teta_dyn)
408    CALL WriteField_u('psfi',ps_dyn)
409    DO iq=1,nqtot
410      CALL WriteField_u('qfi'//trim(int2str(iq)),q_dyn(:,:,iq))
411    ENDDO
412END IF
413
414
415!-jld
416    !$OMP MASTER
417      CALL resume_timer(timer_caldyn)
418    !$OMP END MASTER
419
420  END SUBROUTINE call_calfis
421 
422END MODULE call_calfis_mod
Note: See TracBrowser for help on using the repository browser.