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

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

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