source: LMDZ6/branches/Amaury_dev/libf/dyn3dmem/lmdz_call_calfis.F90 @ 5182

Last change on this file since 5182 was 5182, checked in by abarral, 2 months ago

(WIP) Replace REPROBUS CPP KEY by logical
properly name modules
  • 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.6 KB
Line 
1MODULE lmdz_call_calfis
2
3  USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_DEBUGIO
4
5  REAL, POINTER, SAVE :: ucov(:, :)
6  REAL, POINTER, SAVE :: vcov(:, :)
7  REAL, POINTER, SAVE :: teta(:, :)
8  REAL, POINTER, SAVE :: masse(:, :)
9  REAL, POINTER, SAVE :: ps(:)
10  REAL, POINTER, SAVE :: phis(:)
11  REAL, POINTER, SAVE :: q(:, :, :)
12  REAL, POINTER, SAVE :: flxw(:, :)
13
14  REAL, POINTER, SAVE :: p(:, :)
15  REAL, POINTER, SAVE :: pks(:)
16  REAL, POINTER, SAVE :: pk(:, :)
17  REAL, POINTER, SAVE :: pkf(:, :)
18  REAL, POINTER, SAVE :: phi(:, :)
19  REAL, POINTER, SAVE :: du(:, :)
20  REAL, POINTER, SAVE :: dv(:, :)
21  REAL, POINTER, SAVE :: dteta(:, :)
22  REAL, POINTER, SAVE :: dq(:, :, :)
23  REAL, POINTER, SAVE :: dufi(:, :)
24  REAL, POINTER, SAVE :: dvfi(:, :)
25  REAL, POINTER, SAVE :: dtetafi(:, :)
26  REAL, POINTER, SAVE :: dqfi(:, :, :)
27  REAL, POINTER, SAVE :: dpfi(:)
28
29
30CONTAINS
31
32  SUBROUTINE call_calfis_allocate
33    USE bands
34    USE allocate_field_mod
35    USE parallel_lmdz
36    USE lmdz_dimensions
37    USE lmdz_paramet
38    USE lmdz_infotrac, ONLY: nqtot
39    IMPLICIT NONE
40    TYPE(distrib), POINTER :: d
41    d => distrib_physic
42
43    CALL allocate_u(ucov, llm, d)
44    CALL allocate_v(vcov, llm, d)
45    CALL allocate_u(teta, llm, d)
46    CALL allocate_u(masse, llm, d)
47    CALL allocate_u(ps, d)
48    CALL allocate_u(phis, d)
49    CALL allocate_u(q, llm, nqtot, d)
50    CALL allocate_u(flxw, llm, d)
51    CALL allocate_u(p, llmp1, d)
52    CALL allocate_u(pks, d)
53    pks(:) = 0
54    CALL allocate_u(pk, llm, d)
55    pk(:, :) = 0
56    CALL allocate_u(pkf, llm, d)
57    CALL allocate_u(phi, llm, d)
58    CALL allocate_u(du, llm, d)
59    CALL allocate_v(dv, llm, d)
60    CALL allocate_u(dteta, llm, d)
61    CALL allocate_u(dq, llm, nqtot, d)
62    CALL allocate_u(dufi, llm, d)
63    CALL allocate_v(dvfi, llm, d)
64    CALL allocate_u(dtetafi, llm, d)
65    CALL allocate_u(dqfi, llm, nqtot, d)
66    CALL allocate_u(dpfi, d)
67
68  END SUBROUTINE call_calfis_allocate
69
70
71  SUBROUTINE call_calfis(itau, lafin, ucov_dyn, vcov_dyn, teta_dyn, masse_dyn, ps_dyn, &
72          phis_dyn, q_dyn, flxw_dyn)
73    USE lmdz_dimensions
74    USE lmdz_paramet
75    USE exner_hyb_loc_m, ONLY: exner_hyb_loc
76    USE exner_milieu_loc_m, ONLY: exner_milieu_loc
77    USE parallel_lmdz
78    USE times
79    USE mod_hallo
80    USE Bands
81    USE lmdz_vampir
82    USE lmdz_infotrac, ONLY: nqtot
83    USE control_mod
84    USE write_field_loc
85    USE lmdz_strings, ONLY: int2str
86    USE comconst_mod, ONLY: dtphys
87    USE logic_mod, ONLY: leapf, forward, ok_strato
88    USE comvert_mod, ONLY: ap, bp, pressure_exner
89    USE temps_mod, ONLY: day_ini, day_ref, jd_ref, jh_ref, start_time
90    USE lmdz_calfis_loc
91    USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS
92    USE lmdz_iniprint, ONLY: lunout, prt_level
93
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    IF (CPPKEY_DEBUGIO) THEN
120      CALL WriteField_u('ucovfi', ucov)
121      CALL WriteField_v('vcovfi', vcov)
122      CALL WriteField_u('tetafi', teta)
123      CALL WriteField_u('pfi', p)
124      CALL WriteField_u('pkfi', pk)
125      DO iq = 1, nqtot
126        CALL WriteField_u('qfi' // trim(int2str(iq)), q(:, :, iq))
127      ENDDO
128    END IF
129
130    !     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
131
132    !$OMP MASTER
133    CALL suspend_timer(timer_caldyn)
134    IF (prt_level >= 10) THEN
135      WRITE(lunout, *) 'leapfrog_p: Entree dans la physique : Iteration No ', itau
136    ENDIF
137    !$OMP END MASTER
138
139    jD_cur = jD_ref + day_ini - day_ref + (itau + 1) / day_step
140
141    IF (planet_type =="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 + 1, 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    IF (CPPKEY_DEBUGIO) THEN
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    END IF
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, pks, pk, pkf)
201    !$OMP BARRIER
202    CALL geopot_loc  (ip1jmp1, teta, pk, pks, phis, phi)
203
204    CALL Register_Hallo_u(p, llmp1, 2, 2, 2, 2, Request_physic)
205    CALL Register_Hallo_u(pk, llm, 2, 2, 2, 2, Request_physic)
206    CALL Register_Hallo_u(phi, llm, 2, 2, 2, 2, Request_physic)
207
208    CALL SendRequest(Request_Physic)
209    !$OMP BARRIER
210    CALL WaitRequest(Request_Physic)
211
212    !$OMP BARRIER
213
214    IF (CPPKEY_DEBUGIO) THEN
215      CALL WriteField_u('ucovfi', ucov)
216      CALL WriteField_v('vcovfi', vcov)
217      CALL WriteField_u('tetafi', teta)
218      CALL WriteField_u('pfi', p)
219      CALL WriteField_u('pkfi', pk)
220      DO iq = 1, nqtot
221        CALL WriteField_u('qfi' // trim(int2str(iq)), q(:, :, iq))
222      ENDDO
223    END IF
224
225    !$OMP BARRIER
226
227    IF (CPPKEY_PHYS) THEN
228      CALL calfis_loc(lafin, jD_cur, jH_cur, &
229              ucov, vcov, teta, q, masse, ps, p, pk, phis, phi, &
230              du, dv, dteta, dq, &
231              flxw, dufi, dvfi, dtetafi, dqfi, dpfi)
232    END IF
233    ijb = ij_begin
234    ije = ij_end
235    IF (.NOT. pole_nord) THEN
236
237      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
238      DO l = 1, llm
239        dufi_tmp(1:iip1, l) = dufi(ijb:ijb + iim, l)
240        dvfi_tmp(1:iip1, l) = dvfi(ijb:ijb + iim, l)
241        dtetafi_tmp(1:iip1, l) = dtetafi(ijb:ijb + iim, l)
242        dqfi_tmp(1:iip1, l, :) = dqfi(ijb:ijb + iim, l, :)
243      ENDDO
244      !$OMP END DO NOWAIT
245
246      !$OMP MASTER
247      dpfi_tmp(1:iip1) = dpfi(ijb:ijb + iim)
248      !$OMP END MASTER
249
250    ENDIF ! of if ( .NOT. pole_nord)
251
252    !$OMP BARRIER
253    !$OMP MASTER
254    CALL Set_Distrib(distrib_Physic_bis)
255    CALL VTb(VThallo)
256    !$OMP END MASTER
257    !$OMP BARRIER
258
259    CALL Register_Hallo_u(dufi, llm, 1, 0, 0, 1, Request_physic)
260    CALL Register_Hallo_v(dvfi, llm, 1, 0, 0, 1, Request_physic)
261    CALL Register_Hallo_u(dtetafi, llm, 1, 0, 0, 1, Request_physic)
262    CALL Register_Hallo_u(dpfi, 1, 1, 0, 0, 1, Request_physic)
263
264    DO iq = 1, nqtot
265      CALL Register_Hallo_u(dqfi(:, :, iq), llm, 1, 0, 0, 1, Request_physic)
266    ENDDO
267
268    CALL SendRequest(Request_Physic)
269    !$OMP BARRIER
270    CALL WaitRequest(Request_Physic)
271
272    !$OMP BARRIER
273    !$OMP MASTER
274    CALL VTe(VThallo)
275    CALL Set_Distrib(distrib_Physic)
276    !$OMP END MASTER
277    !$OMP BARRIER
278    ijb = ij_begin
279    IF (.NOT. pole_nord) THEN
280
281      !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
282      DO l = 1, llm
283        dufi(ijb:ijb + iim, l) = dufi(ijb:ijb + iim, l) + dufi_tmp(1:iip1, l)
284        dvfi(ijb:ijb + iim, l) = dvfi(ijb:ijb + iim, l) + dvfi_tmp(1:iip1, l)
285        dtetafi(ijb:ijb + iim, l) = dtetafi(ijb:ijb + iim, l) + dtetafi_tmp(1:iip1, l)
286        dqfi(ijb:ijb + iim, l, :) = dqfi(ijb:ijb + iim, l, :) + dqfi_tmp(1:iip1, l, :)
287      ENDDO
288      !$OMP END DO NOWAIT
289
290      !$OMP MASTER
291      dpfi(ijb:ijb + iim) = dpfi(ijb:ijb + iim) + dpfi_tmp(1:iip1)
292      !$OMP END MASTER
293
294    endif ! of if (.NOT. pole_nord)
295
296    IF (CPPKEY_DEBUGIO) THEN
297      CALL WriteField_u('dufi', dufi)
298      CALL WriteField_v('dvfi', dvfi)
299      CALL WriteField_u('dtetafi', dtetafi)
300      CALL WriteField_u('dpfi', dpfi)
301      DO iq = 1, nqtot
302        CALL WriteField_u('dqfi' // trim(int2str(iq)), dqfi(:, :, iq))
303      ENDDO
304    END IF
305
306    !$OMP BARRIER
307
308    !      ajout des tendances physiques:
309    !      ------------------------------
310    IF (CPPKEY_DEBUGIO) THEN
311      CALL WriteField_u('ucovfi', ucov)
312      CALL WriteField_v('vcovfi', vcov)
313      CALL WriteField_u('tetafi', teta)
314      CALL WriteField_u('psfi', ps)
315      DO iq = 1, nqtot
316        CALL WriteField_u('qfi' // trim(int2str(iq)), q(:, :, iq))
317      ENDDO
318    END IF
319
320    IF (CPPKEY_DEBUGIO) THEN
321      CALL WriteField_u('ucovfi', ucov)
322      CALL WriteField_v('vcovfi', vcov)
323      CALL WriteField_u('tetafi', teta)
324      CALL WriteField_u('psfi', ps)
325      DO iq = 1, nqtot
326        CALL WriteField_u('qfi' // trim(int2str(iq)), q(:, :, iq))
327      ENDDO
328    END IF
329
330    CALL addfi_loc(dtphys, leapf, forward, &
331            ucov, vcov, teta, q, ps, &
332            dufi, dvfi, dtetafi, dqfi, dpfi)
333    ! since addfi updates ps(), also update p(), masse() and pk()
334    CALL pression_loc(ip1jmp1, ap, bp, ps, p)
335    !$OMP BARRIER
336    CALL massdair_loc(p, masse)
337    !$OMP BARRIER
338    IF (pressure_exner) THEN
339      CALL exner_hyb_loc(ijnb_u, ps, p, pks, pk, pkf)
340    else
341      CALL exner_milieu_loc(ijnb_u, ps, p, pks, pk, pkf)
342    endif
343    !$OMP BARRIER
344
345    IF (CPPKEY_DEBUGIO) THEN
346      CALL WriteField_u('ucovfi', ucov)
347      CALL WriteField_v('vcovfi', vcov)
348      CALL WriteField_u('tetafi', teta)
349      CALL WriteField_u('psfi', ps)
350      DO iq = 1, nqtot
351        CALL WriteField_u('qfi' // trim(int2str(iq)), q(:, :, iq))
352      ENDDO
353    END IF
354
355    IF (ok_strato) THEN
356      !      CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi)
357      CALL top_bound_loc(vcov, ucov, teta, masse, dtphys)
358    ENDIF
359
360    !$OMP BARRIER
361    !$OMP MASTER
362    CALL VTe(VTphysiq)
363    CALL VTb(VThallo)
364    !$OMP END MASTER
365
366    CALL SetTag(Request_physic, 800)
367    CALL Register_SwapField_u(ucov, ucov_dyn, distrib_caldyn, Request_physic)
368    CALL Register_SwapField_v(vcov, vcov_dyn, distrib_caldyn, Request_physic)
369    CALL Register_SwapField_u(teta, teta_dyn, distrib_caldyn, Request_physic)
370    CALL Register_SwapField_u(masse, masse_dyn, distrib_caldyn, Request_physic)
371    CALL Register_SwapField_u(ps, ps_dyn, distrib_caldyn, Request_physic)
372    CALL Register_SwapField_u(q, q_dyn, distrib_caldyn, Request_physic)
373    CALL SendRequest(Request_Physic)
374    !$OMP BARRIER
375    CALL WaitRequest(Request_Physic)
376
377    !$OMP BARRIER
378    !$OMP MASTER
379    CALL VTe(VThallo)
380    CALL set_distrib(distrib_caldyn)
381    !$OMP END MASTER
382    !$OMP BARRIER
383
384    !  Diagnostique de conservation de l'energie : difference
385    IF (ip_ebil_dyn>=1) THEN
386      ztit = 'bil phys'
387      !      CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2))
388      WRITE(lunout, *)"call_calfis: diagedyn disabled in dyn3dmem !!"
389    ENDIF
390
391    IF (CPPKEY_DEBUGIO) THEN
392      CALL WriteField_u('ucovfi', ucov_dyn)
393      CALL WriteField_v('vcovfi', vcov_dyn)
394      CALL WriteField_u('tetafi', teta_dyn)
395      CALL WriteField_u('psfi', ps_dyn)
396      DO iq = 1, nqtot
397        CALL WriteField_u('qfi' // trim(int2str(iq)), q_dyn(:, :, iq))
398      ENDDO
399    END IF
400
401
402    !-jld
403    !$OMP MASTER
404    CALL resume_timer(timer_caldyn)
405    !$OMP END MASTER
406
407  END SUBROUTINE call_calfis
408
409END MODULE lmdz_call_calfis
Note: See TracBrowser for help on using the repository browser.