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

Last change on this file since 5748 was 5748, checked in by dcugnet, 3 weeks ago
  • Use REAL(KIND=REAL32) and REAL(KIND=REAL64) Iinstead of REAL and DOUBLE PRECISION

to avoid ambiguity problems in generic procedure when reals are promoted to doubles.

  • generic "num2str" replaces "str2int", "str2real", "str2dble" and "str2bool" functions.
  • 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: 10.0 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
40  USE infotrac, ONLY: nqtot
41  IMPLICIT NONE
42    TYPE(distrib),POINTER :: d
43    d=>distrib_physic
44
45    CALL allocate_u(ucov,llm,d)
46    CALL allocate_v(vcov,llm,d)
47    CALL allocate_u(teta,llm,d)
48    CALL allocate_u(masse,llm,d)
49    CALL allocate_u(ps,d)
50    CALL allocate_u(phis,d)
51    CALL allocate_u(q,llm,nqtot,d)
52    CALL allocate_u(flxw,llm,d)
53    CALL allocate_u(p,llmp1,d)
54    CALL allocate_u(pks,d)
55    pks(:)=0
56    CALL allocate_u(pk,llm,d)
57    pk(:,:)=0
58    CALL allocate_u(pkf,llm,d)
59    CALL allocate_u(phi,llm,d)
60    CALL allocate_u(du,llm,d)
61    CALL allocate_v(dv,llm,d)
62    CALL allocate_u(dteta,llm,d)
63    CALL allocate_u(dq,llm,nqtot,d)
64    CALL allocate_u(dufi,llm,d)
65    CALL allocate_v(dvfi,llm,d)
66    CALL allocate_u(dtetafi,llm,d)
67    CALL allocate_u(dqfi,llm,nqtot,d)
68    CALL allocate_u(dpfi,d)
69
70  END SUBROUTINE call_calfis_allocate
71
72
73  SUBROUTINE call_calfis(itau,lafin,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, &
74                         phis_dyn,q_dyn,flxw_dyn)
75  USE dimensions_mod, ONLY: iim, jjm, llm, ndm
76  USE paramet_mod_h
77  USE exner_hyb_loc_m, only: exner_hyb_loc
78  use exner_milieu_loc_m, only: exner_milieu_loc
79  USE parallel_lmdz
80  USE times
81  USE mod_hallo
82  USE Bands
83  USE vampir
84  USE infotrac, ONLY: nqtot
85  USE control_mod
86  USE write_field_loc
87  USE write_field
88  USE comconst_mod, ONLY: dtphys
89  USE logic_mod, ONLY: leapf, forward, ok_strato
90  USE comvert_mod, ONLY: ap, bp, pressure_exner
91  USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time
92  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
93  USE iniprint_mod_h
94  IMPLICIT NONE
95
96    INTEGER,INTENT(IN) :: itau ! (time) iteration step number
97    LOGICAL,INTENT(IN) :: lafin ! .true. if final time step
98    REAL,INTENT(INOUT) :: ucov_dyn(ijb_u:ije_u,llm) ! covariant zonal wind
99    REAL,INTENT(INOUT) :: vcov_dyn(ijb_v:ije_v,llm) ! covariant meridional wind
100    REAL,INTENT(INOUT) :: teta_dyn(ijb_u:ije_u,llm) ! potential temperature
101    REAL,INTENT(INOUT) :: masse_dyn(ijb_u:ije_u,llm) ! air mass
102    REAL,INTENT(INOUT) :: ps_dyn(ijb_u:ije_u) ! surface pressure
103    REAL,INTENT(INOUT) :: phis_dyn(ijb_u:ije_u) ! surface geopotential
104    REAL,INTENT(INOUT) :: q_dyn(ijb_u:ije_u,llm,nqtot) ! advected tracers
105    REAL,INTENT(INOUT) :: flxw_dyn(ijb_u:ije_u,llm) ! vertical mass flux
106
107    REAL :: dufi_tmp(iip1,llm)   
108    REAL :: dvfi_tmp(iip1,llm) 
109    REAL :: dtetafi_tmp(iip1,llm)
110    REAL :: dpfi_tmp(iip1)
111    REAL :: dqfi_tmp(iip1,llm,nqtot)
112
113    REAL :: jD_cur, jH_cur
114    CHARACTER(LEN=15) :: ztit
115    TYPE(Request),SAVE :: Request_physic
116!$OMP THREADPRIVATE(Request_physic )
117    INTEGER :: ijb,ije,l,iq
118
119!
120!     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
121!
122
123
124  !$OMP MASTER
125    CALL suspend_timer(timer_caldyn)
126    IF (prt_level >= 10) THEN
127      WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau
128    ENDIF
129  !$OMP END MASTER
130   
131           jD_cur = jD_ref + day_ini - day_ref                           &
132     &        + (itau+1)/day_step
133
134           IF (planet_type .eq."generic") THEN
135              ! AS: we make jD_cur to be pday
136              jD_cur = int(day_ini + itau/day_step)
137           ENDIF
138
139           jH_cur = jH_ref + start_time +                                &
140     &              mod(itau+1,day_step)/float(day_step)
141    if (jH_cur > 1.0 ) then
142      jD_cur = jD_cur +1.
143      jH_cur = jH_cur -1.
144    endif
145
146!   Inbterface avec les routines de phylmd (phymars ... )
147!   -----------------------------------------------------
148
149!+jld
150
151!  Diagnostique de conservation de l'energie : initialisation
152 
153!-jld
154  !$OMP BARRIER
155  !$OMP MASTER
156    CALL VTb(VThallo)
157  !$OMP END MASTER
158   
159    CALL SetTag(Request_physic,800)
160    CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2)
161    CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2)
162    CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2)
163    CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2)
164    CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2)
165    CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2)
166    CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2)
167    CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2)
168 
169    CALL SendRequest(Request_Physic)
170  !$OMP BARRIER
171    CALL WaitRequest(Request_Physic)       
172
173  !$OMP BARRIER
174  !$OMP MASTER
175    CALL Set_Distrib(distrib_Physic)
176    CALL VTe(VThallo)
177       
178    CALL VTb(VTphysiq)
179  !$OMP END MASTER
180  !$OMP BARRIER
181
182    CALL pression_loc (  ip1jmp1, ap, bp, ps,  p      )
183
184  !$OMP BARRIER
185    CALL exner_hyb_loc(  ip1jmp1, ps, p, pks, pk, pkf )
186  !$OMP BARRIER
187    CALL geopot_loc  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
188
189
190    CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic)
191    CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic)
192    CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic)
193       
194    CALL SendRequest(Request_Physic)
195  !$OMP BARRIER
196    CALL WaitRequest(Request_Physic)
197
198  !$OMP BARRIER
199
200IF (CPPKEY_PHYS) THEN
201    CALL calfis_loc(lafin ,jD_cur, jH_cur,                       &
202                     ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,   &
203                     du,dv,dteta,dq,                             &
204                     flxw, dufi,dvfi,dtetafi,dqfi,dpfi  )
205END IF
206    ijb=ij_begin
207    ije=ij_end 
208    IF ( .not. pole_nord) THEN
209 
210    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
211      DO l=1,llm
212        dufi_tmp(1:iip1,l)   = dufi(ijb:ijb+iim,l)
213        dvfi_tmp(1:iip1,l)   = dvfi(ijb:ijb+iim,l) 
214        dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) 
215        dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) 
216      ENDDO
217    !$OMP END DO NOWAIT
218
219    !$OMP MASTER
220      dpfi_tmp(1:iip1)     = dpfi(ijb:ijb+iim) 
221    !$OMP END MASTER
222   
223    ENDIF ! of if ( .not. pole_nord)
224
225  !$OMP BARRIER
226  !$OMP MASTER
227    CALL Set_Distrib(distrib_Physic_bis)
228    CALL VTb(VThallo)
229  !$OMP END MASTER
230  !$OMP BARRIER
231 
232    CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic)
233    CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic)
234    CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic)
235    CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic)
236
237    DO iq=1,nqtot
238      CALL Register_Hallo_u(dqfi(:,:,iq),llm,1,0,0,1,Request_physic)
239    ENDDO
240       
241    CALL SendRequest(Request_Physic)
242  !$OMP BARRIER
243    CALL WaitRequest(Request_Physic)
244             
245  !$OMP BARRIER
246  !$OMP MASTER
247    CALL VTe(VThallo)
248    CALL Set_Distrib(distrib_Physic)
249  !$OMP END MASTER
250  !$OMP BARRIER       
251    ijb=ij_begin
252    IF (.not. pole_nord) THEN
253       
254    !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
255      DO l=1,llm
256        dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l)
257        dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l)
258        dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l)
259        dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:)
260      ENDDO
261    !$OMP END DO NOWAIT
262
263    !$OMP MASTER
264      dpfi(ijb:ijb+iim)   = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1)
265    !$OMP END MASTER
266         
267    endif ! of if (.not. pole_nord)
268
269
270  !$OMP BARRIER
271
272!      ajout des tendances physiques:
273!      ------------------------------
274
275    CALL addfi_loc( dtphys, leapf, forward   ,              &
276                    ucov, vcov, teta , q   ,ps ,            &
277                    dufi, dvfi, dtetafi , dqfi ,dpfi  )
278    ! since addfi updates ps(), also update p(), masse() and pk()
279    CALL pression_loc(ip1jmp1,ap,bp,ps,p)
280!$OMP BARRIER
281    CALL massdair_loc(p,masse)
282!$OMP BARRIER
283    if (pressure_exner) then
284      CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf)
285    else
286      CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf)
287    endif
288!$OMP BARRIER
289
290    IF (ok_strato) THEN
291!      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
292      CALL top_bound_loc(vcov,ucov,teta,masse,dtphys)
293    ENDIF
294
295  !$OMP BARRIER
296  !$OMP MASTER
297    CALL VTe(VTphysiq)
298    CALL VTb(VThallo)
299  !$OMP END MASTER
300
301    CALL SetTag(Request_physic,800)
302    CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic)
303    CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic)
304    CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic)
305    CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic)
306    CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic)
307    CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic)
308    CALL SendRequest(Request_Physic)
309  !$OMP BARRIER
310    CALL WaitRequest(Request_Physic)     
311
312  !$OMP BARRIER
313  !$OMP MASTER
314    CALL VTe(VThallo)
315    CALL set_distrib(distrib_caldyn)
316  !$OMP END MASTER
317  !$OMP BARRIER
318
319!
320!  Diagnostique de conservation de l'energie : difference
321    IF (ip_ebil_dyn.ge.1 ) THEN
322      ztit='bil phys'
323!      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
324      write(lunout,*)"call_calfis: diagedyn disabled in dyn3dmem !!"
325    ENDIF
326
327!-jld
328    !$OMP MASTER
329      CALL resume_timer(timer_caldyn)
330    !$OMP END MASTER
331
332  END SUBROUTINE call_calfis
333 
334END MODULE call_calfis_mod
Note: See TracBrowser for help on using the repository browser.